{-# LANGUAGE CPP             #-}
{-# LANGUAGE Arrows          #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.ODT.StyleReader
   Copyright   : Copyright (C) 2015 Martin Linnemann
   License     : GNU GPL, version 2 or above

   Maintainer  : Martin Linnemann <theCodingMarlin@googlemail.com>
   Stability   : alpha
   Portability : portable

Reader for the style information in an odt document.
-}

module Text.Pandoc.Readers.ODT.StyleReader
( Style                (..)
, StyleName
, StyleFamily          (..)
, Styles               (..)
, StyleProperties      (..)
, TextProperties       (..)
, ParaProperties       (..)
, VerticalTextPosition (..)
, ListItemNumberFormat (..)
, ListLevel
, ListStyle            (..)
, ListLevelStyle       (..)
, ListLevelType        (..)
, LengthOrPercent      (..)
, lookupStyle
, getListLevelStyle
, getStyleFamily
, lookupDefaultStyle'
, lookupListStyleByName
, extendedStylePropertyChain
, readStylesAt
) where

import Prelude hiding (Applicative(..))
import Control.Applicative hiding (liftA, liftA2, liftA3)
import Control.Arrow

import Data.Default
import qualified Data.Foldable as F
import Data.List (unfoldr, foldl')
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Set as S

import qualified Text.Pandoc.XML.Light as XML

import Text.Pandoc.Shared (safeRead, tshow)

import Text.Pandoc.Readers.ODT.Arrows.Utils

import Text.Pandoc.Readers.ODT.Generic.Fallible
import qualified Text.Pandoc.Readers.ODT.Generic.SetMap as SM
import Text.Pandoc.Readers.ODT.Generic.Utils
import Text.Pandoc.Readers.ODT.Generic.XMLConverter

import Text.Pandoc.Readers.ODT.Base
import Text.Pandoc.Readers.ODT.Namespaces

readStylesAt :: XML.Element -> Fallible Styles
readStylesAt :: Element -> Fallible Styles
readStylesAt Element
e = forall nsID extraState success.
NameSpaceID nsID =>
FallibleXMLConverter nsID extraState () success
-> extraState -> Element -> Fallible success
runConverter' forall _x. StyleReader _x Styles
readAllStyles 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontPitch -> FontPitch -> Bool
$c/= :: FontPitch -> FontPitch -> Bool
== :: FontPitch -> FontPitch -> Bool
$c== :: FontPitch -> FontPitch -> Bool
Eq, Int -> FontPitch -> ShowS
[FontPitch] -> ShowS
FontPitch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontPitch] -> ShowS
$cshowList :: [FontPitch] -> ShowS
show :: FontPitch -> String
$cshow :: FontPitch -> String
showsPrec :: Int -> FontPitch -> ShowS
$cshowsPrec :: Int -> 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 are only needed at one later place, so it should not be
-- transported on the value level, especially as we already use a state arrow.
-- So instead, the resulting map is lifted into the state of the reader.
-- (An alternative might be ImplicitParams, but again, we already have a state.)
--
-- So the main style readers will have the types
type StyleReader     a b  = XMLReader     FontPitches a b
-- and
type StyleReaderSafe a b  = XMLReaderSafe FontPitches a b
-- respectively.
--
-- But before we can work with these, we need to define the reader that reads
-- the fonts:

-- | A reader for font pitches
fontPitchReader :: XMLReader _s _x FontPitches
fontPitchReader :: forall _s _x. XMLReader _s _x FontPitches
fontPitchReader = forall nsID extraState f s.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeInSub Namespace
NsOffice StyleName
"font-face-decls" (
                          forall nsID extraState a b.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState a b
-> FallibleXMLConverter nsID extraState a [b]
withEveryL Namespace
NsStyle StyleName
"font-face" (forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess (
                              forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr' Namespace
NsStyle StyleName
"name"
                              forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
                              forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a, Default a) =>
nsID -> StyleName -> XMLConverter nsID extraState x a
lookupDefaultingAttr Namespace
NsStyle StyleName
"font-pitch"
                            ))
                    forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> (success -> success') -> FallibleArrow a x failure success'
>>?^ ( forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {b}. [(a, b)] -> (Maybe a, b) -> [(a, b)]
accumLegalPitches [] )
                  ) forall (a :: * -> * -> *) x f y.
ArrowChoice a =>
FallibleArrow a x f y
-> FallibleArrow a x f y -> FallibleArrow a x f y
`ifFailedDo` forall (a :: * -> * -> *) c x. Arrow a => c -> a x c
returnV (forall a b. b -> Either a b
Right forall k a. Map k a
M.empty)
  where accumLegalPitches :: [(a, b)] -> (Maybe a, b) -> [(a, b)]
accumLegalPitches [(a, b)]
ls (Maybe a
Nothing,b
_) = [(a, b)]
ls
        accumLegalPitches [(a, b)]
ls (Just a
n,b
p)  = (a
n,b
p)forall a. a -> [a] -> [a]
:[(a, b)]
ls


-- | A wrapper around the font pitch reader that lifts the result into the
-- state.
readFontPitches :: StyleReader x x
readFontPitches :: forall x. StyleReader x x
readFontPitches = forall extraState' a nsID extraState x.
extraState'
-> a
-> FallibleXMLConverter nsID extraState' a extraState
-> FallibleXMLConverter nsID extraState x x
producingExtraState () () forall _s _x. XMLReader _s _x FontPitches
fontPitchReader


-- | Looking up a pitch in the state of the arrow.
--
-- The function does the following:
-- * Look for the font pitch in an attribute.
-- * If that fails, look for the font name, look up the font in the state
--   and use the pitch from there.
-- * Return the result in a Maybe
--
findPitch :: XMLReaderSafe FontPitches _x (Maybe FontPitch)
findPitch :: forall _x. XMLReaderSafe FontPitches _x (Maybe FontPitch)
findPitch =     ( forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> FallibleXMLConverter nsID extraState x a
lookupAttr Namespace
NsStyle StyleName
"font-pitch"
                  forall (a :: * -> * -> *) x f y.
ArrowChoice a =>
FallibleArrow a x f y
-> FallibleArrow a x f y -> FallibleArrow a x f y
`ifFailedDo`     forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x StyleName
findAttr Namespace
NsStyle StyleName
"font-name"
                               forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> FallibleArrow a success failure success'
-> FallibleArrow a x failure success'
>>? (     forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue forall nsID extraState x. XMLConverter nsID extraState x extraState
getExtraState
                                     forall (a :: * -> * -> *) x b c d.
Arrow a =>
a x (b, c) -> (b -> c -> d) -> a x d
>>% forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup
                                     forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall (a :: * -> * -> *) b.
ArrowChoice a =>
a (Maybe b) (Fallible b)
maybeToChoice
                                   )
                )
            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) l r.
ArrowChoice a =>
a (Either l r) (Maybe r)
choiceToMaybe

--------------------------------------------------------------------------------
-- Definitions of main data
--------------------------------------------------------------------------------

type StyleName        = Text

-- | There are two types of styles: named styles with a style family and an
-- optional style parent, and default styles for each style family,
-- defining default style properties
data Styles           = Styles
                          { 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Styles] -> ShowS
$cshowList :: [Styles] -> ShowS
show :: Styles -> String
$cshow :: Styles -> String
showsPrec :: Int -> Styles -> ShowS
$cshowsPrec :: Int -> 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 (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map StyleName Style
sBn1  Map StyleName Style
sBn2)
                   (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map StyleName ListStyle
dSm1  Map StyleName ListStyle
dSm2)
                   (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 forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty
  mappend :: Styles -> Styles -> Styles
mappend = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StyleFamily -> StyleFamily -> Bool
$c/= :: StyleFamily -> StyleFamily -> Bool
== :: StyleFamily -> StyleFamily -> Bool
$c== :: StyleFamily -> StyleFamily -> Bool
Eq, Eq 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
min :: StyleFamily -> StyleFamily -> StyleFamily
$cmin :: StyleFamily -> StyleFamily -> StyleFamily
max :: StyleFamily -> StyleFamily -> StyleFamily
$cmax :: StyleFamily -> StyleFamily -> StyleFamily
>= :: StyleFamily -> StyleFamily -> Bool
$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
compare :: StyleFamily -> StyleFamily -> Ordering
$ccompare :: StyleFamily -> StyleFamily -> Ordering
Ord, Int -> StyleFamily -> ShowS
[StyleFamily] -> ShowS
StyleFamily -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleFamily] -> ShowS
$cshowList :: [StyleFamily] -> ShowS
show :: StyleFamily -> String
$cshow :: StyleFamily -> String
showsPrec :: Int -> StyleFamily -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
Eq, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Style] -> ShowS
$cshowList :: [Style] -> ShowS
show :: Style -> String
$cshow :: Style -> String
showsPrec :: Int -> Style -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StyleProperties -> StyleProperties -> Bool
$c/= :: StyleProperties -> StyleProperties -> Bool
== :: StyleProperties -> StyleProperties -> Bool
$c== :: StyleProperties -> StyleProperties -> Bool
Eq, Int -> StyleProperties -> ShowS
[StyleProperties] -> ShowS
StyleProperties -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleProperties] -> ShowS
$cshowList :: [StyleProperties] -> ShowS
show :: StyleProperties -> String
$cshow :: StyleProperties -> String
showsPrec :: Int -> StyleProperties -> ShowS
$cshowsPrec :: Int -> StyleProperties -> ShowS
Show )

instance  Default StyleProperties where
  def :: StyleProperties
def =                SProps { textProperties :: Maybe TextProperties
textProperties       = forall a. a -> Maybe a
Just forall a. Default a => a
def
                               , paraProperties :: Maybe ParaProperties
paraProperties      = forall a. a -> Maybe a
Just 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextProperties -> TextProperties -> Bool
$c/= :: TextProperties -> TextProperties -> Bool
== :: TextProperties -> TextProperties -> Bool
$c== :: TextProperties -> TextProperties -> Bool
Eq, Int -> TextProperties -> ShowS
[TextProperties] -> ShowS
TextProperties -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextProperties] -> ShowS
$cshowList :: [TextProperties] -> ShowS
show :: TextProperties -> String
$cshow :: TextProperties -> String
showsPrec :: Int -> TextProperties -> ShowS
$cshowsPrec :: Int -> 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            = forall a. a -> Maybe a
Just forall a. Default a => a
def
                               , verticalPosition :: VerticalTextPosition
verticalPosition = forall a. Default a => a
def
                               , underline :: Maybe UnderlineMode
underline        = forall a. Maybe a
Nothing
                               , strikethrough :: Maybe UnderlineMode
strikethrough    = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParaProperties -> ParaProperties -> Bool
$c/= :: ParaProperties -> ParaProperties -> Bool
== :: ParaProperties -> ParaProperties -> Bool
$c== :: ParaProperties -> ParaProperties -> Bool
Eq, Int -> ParaProperties -> ShowS
[ParaProperties] -> ShowS
ParaProperties -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParaProperties] -> ShowS
$cshowList :: [ParaProperties] -> ShowS
show :: ParaProperties -> String
$cshow :: ParaProperties -> String
showsPrec :: Int -> ParaProperties -> ShowS
$cshowsPrec :: Int -> ParaProperties -> ShowS
Show )

instance Default ParaProperties where
  def :: ParaProperties
def =                 PropP { paraNumbering :: ParaNumbering
paraNumbering = ParaNumbering
NumberingNone
                              , indentation :: LengthOrPercent
indentation   = forall a. Default a => a
def
                              , margin_left :: LengthOrPercent
margin_left   = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VerticalTextPosition -> VerticalTextPosition -> Bool
$c/= :: VerticalTextPosition -> VerticalTextPosition -> Bool
== :: VerticalTextPosition -> VerticalTextPosition -> Bool
$c== :: VerticalTextPosition -> VerticalTextPosition -> Bool
Eq, Int -> VerticalTextPosition -> ShowS
[VerticalTextPosition] -> ShowS
VerticalTextPosition -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerticalTextPosition] -> ShowS
$cshowList :: [VerticalTextPosition] -> ShowS
show :: VerticalTextPosition -> String
$cshow :: VerticalTextPosition -> String
showsPrec :: Int -> VerticalTextPosition -> ShowS
$cshowsPrec :: Int -> 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          ]
                  forall a. [a] -> [a] -> [a]
++ [ (VerticalTextPosition
VPosSuper      , String
s') | (String
"super" , String
s') <- [(String, String)]
lexS          ]
                  forall a. [a] -> [a] -> [a]
++ [ (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 forall a. Ord a => a -> a -> Bool
< a
0     = VerticalTextPosition
VPosSub
                     | a
n forall a. Ord a => a -> a -> Bool
> a
0     = VerticalTextPosition
VPosSuper
                     | Bool
otherwise = VerticalTextPosition
VPosNormal

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

data LengthOrPercent = LengthValueMM Int | PercentValue Int
  deriving ( LengthOrPercent -> LengthOrPercent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LengthOrPercent -> LengthOrPercent -> Bool
$c/= :: LengthOrPercent -> LengthOrPercent -> Bool
== :: LengthOrPercent -> LengthOrPercent -> Bool
$c== :: LengthOrPercent -> LengthOrPercent -> Bool
Eq, Int -> LengthOrPercent -> ShowS
[LengthOrPercent] -> ShowS
LengthOrPercent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LengthOrPercent] -> ShowS
$cshowList :: [LengthOrPercent] -> ShowS
show :: LengthOrPercent -> String
$cshow :: LengthOrPercent -> String
showsPrec :: Int -> LengthOrPercent -> ShowS
$cshowsPrec :: Int -> 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]
   forall a. [a] -> [a] -> [a]
++ [ (Int -> LengthOrPercent
LengthValueMM Int
lengthMM , String
s'') | (Double
length' , String
s' ) <- forall a. Read a => ReadS a
reads String
s
                                       , (XslUnit
unit    , String
s'') <- 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     = forall a b. (RealFrac a, Integral b) => a -> b
round Double
n
estimateInMillimeter Double
n XslUnit
XslUnitCM     = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* Double
10
estimateInMillimeter Double
n XslUnit
XslUnitInch   = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitPoints = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* (Double
1forall a. Fractional a => a -> a -> a
/Double
72) forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitPica   = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* Double
12 forall a. Num a => a -> a -> a
* (Double
1forall a. Fractional a => a -> a -> a
/Double
72) forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitPixel  = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* (Double
1forall a. Fractional a => a -> a -> a
/Double
72) forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitEM     = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* Double
16 forall a. Num a => a -> a -> a
* (Double
1forall a. Fractional a => a -> a -> a
/Double
72) 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListStyle -> ListStyle -> Bool
$c/= :: ListStyle -> ListStyle -> Bool
== :: ListStyle -> ListStyle -> Bool
$c== :: ListStyle -> ListStyle -> Bool
Eq, Int -> ListStyle -> ShowS
[ListStyle] -> ShowS
ListStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ListStyle] -> ShowS
$cshowList :: [ListStyle] -> ShowS
show :: ListStyle -> String
$cshow :: ListStyle -> String
showsPrec :: Int -> ListStyle -> ShowS
$cshowsPrec :: Int -> ListStyle -> ShowS
Show )

--
getListLevelStyle :: ListLevel -> ListStyle -> Maybe ListLevelStyle
getListLevelStyle :: Int -> ListStyle -> Maybe ListLevelStyle
getListLevelStyle Int
level ListStyle{Map Int ListLevelStyle
levelStyles :: Map Int ListLevelStyle
levelStyles :: ListStyle -> Map Int ListLevelStyle
..} =
  let (Map Int ListLevelStyle
lower , Maybe ListLevelStyle
exactHit , 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListLevelStyle -> ListLevelStyle -> Bool
$c/= :: ListLevelStyle -> ListLevelStyle -> Bool
== :: ListLevelStyle -> ListLevelStyle -> Bool
$c== :: ListLevelStyle -> ListLevelStyle -> Bool
Eq, Eq 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
min :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
$cmin :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
max :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
$cmax :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
>= :: ListLevelStyle -> ListLevelStyle -> Bool
$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
compare :: ListLevelStyle -> ListLevelStyle -> Ordering
$ccompare :: ListLevelStyle -> ListLevelStyle -> Ordering
Ord )

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

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

data ListItemNumberFormat = LinfNone
                          | LinfNumber
                          | LinfRomanLC | LinfRomanUC
                          | LinfAlphaLC | LinfAlphaUC
                          | LinfString String
  deriving ( ListItemNumberFormat -> ListItemNumberFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$c/= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
== :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$c== :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
Eq, Eq 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
min :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
$cmin :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
max :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
$cmax :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
>= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$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
compare :: ListItemNumberFormat -> ListItemNumberFormat -> Ordering
$ccompare :: ListItemNumberFormat -> ListItemNumberFormat -> Ordering
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 _x Styles
readAllStyles :: forall _x. StyleReader _x Styles
readAllStyles = (      forall x. StyleReader x x
readFontPitches
                  forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! (     forall _x. StyleReader _x Styles
readAutomaticStyles
                         forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall _x. StyleReader _x Styles
readStyles ))
                  forall (a :: * -> * -> *) x f b b' c.
ArrowChoice a =>
FallibleArrow a x f (b, b')
-> (b -> b' -> Either f c) -> FallibleArrow a x f c
>>?%? forall a b.
(Monoid a, Monoid b) =>
Either a b -> Either a b -> Either a b
chooseMax
 -- all top elements are always on the same hierarchy level

--
readStyles :: StyleReader _x Styles
readStyles :: forall _x. StyleReader _x Styles
readStyles = forall nsID extraState f s.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeInSub Namespace
NsOffice StyleName
"styles" forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
  forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) z y x r b.
Arrow a =>
(z -> y -> x -> r) -> a b z -> a b y -> a b x -> a b r
liftA3 Map StyleName Style
-> Map StyleName ListStyle
-> Map StyleFamily StyleProperties
-> Styles
Styles
    ( forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsStyle StyleName
"style"         forall _x. StyleReader _x (StyleName, Style)
readStyle        forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsText  StyleName
"list-style"    forall _x. StyleReader _x (StyleName, ListStyle)
readListStyle    forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsStyle StyleName
"default-style" forall _x. StyleReader _x (StyleFamily, StyleProperties)
readDefaultStyle forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )

--
readAutomaticStyles :: StyleReader _x Styles
readAutomaticStyles :: forall _x. StyleReader _x Styles
readAutomaticStyles = forall nsID extraState f s.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeInSub Namespace
NsOffice StyleName
"automatic-styles" forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
  forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) z y x r b.
Arrow a =>
(z -> y -> x -> r) -> a b z -> a b y -> a b x -> a b r
liftA3 Map StyleName Style
-> Map StyleName ListStyle
-> Map StyleFamily StyleProperties
-> Styles
Styles
    ( forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsStyle StyleName
"style"         forall _x. StyleReader _x (StyleName, Style)
readStyle        forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsText  StyleName
"list-style"    forall _x. StyleReader _x (StyleName, ListStyle)
readListStyle    forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( forall (a :: * -> * -> *) c x. Arrow a => c -> a x c
returnV forall k a. Map k a
M.empty                                                )

--
readDefaultStyle :: StyleReader _x (StyleFamily, StyleProperties)
readDefaultStyle :: forall _x. StyleReader _x (StyleFamily, StyleProperties)
readDefaultStyle =      forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> FallibleXMLConverter nsID extraState x a
lookupAttr Namespace
NsStyle StyleName
"family"
                   forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue forall _x. StyleReaderSafe _x StyleProperties
readStyleProperties

--
readStyle :: StyleReader _x (StyleName,Style)
readStyle :: forall _x. StyleReader _x (StyleName, Style)
readStyle =      forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x StyleName
findAttr Namespace
NsStyle StyleName
"name"
            forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue
                   ( forall (a :: * -> * -> *) z y x w r b.
Arrow a =>
(z -> y -> x -> w -> r)
-> a b z -> a b y -> a b x -> a b w -> a b r
liftA4 Maybe StyleFamily
-> Maybe StyleName -> Maybe StyleName -> StyleProperties -> Style
Style
                       ( forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> XMLConverter nsID extraState x (Maybe a)
lookupAttr' Namespace
NsStyle StyleName
"family"            )
                       ( forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'   Namespace
NsStyle StyleName
"parent-style-name" )
                       ( forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'   Namespace
NsStyle StyleName
"list-style-name"   )
                       forall _x. StyleReaderSafe _x StyleProperties
readStyleProperties
                   )

--
readStyleProperties :: StyleReaderSafe _x StyleProperties
readStyleProperties :: forall _x. StyleReaderSafe _x StyleProperties
readStyleProperties = forall (a :: * -> * -> *) x y z b.
Arrow a =>
(x -> y -> z) -> a b x -> a b y -> a b z
liftA2 Maybe TextProperties -> Maybe ParaProperties -> StyleProperties
SProps
                       ( forall _x. StyleReader _x TextProperties
readTextProperties forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) l r.
ArrowChoice a =>
a (Either l r) (Maybe r)
choiceToMaybe )
                       ( forall _x. StyleReader _x ParaProperties
readParaProperties forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) l r.
ArrowChoice a =>
a (Either l r) (Maybe r)
choiceToMaybe )

--
readTextProperties :: StyleReader _x TextProperties
readTextProperties :: forall _x. StyleReader _x TextProperties
readTextProperties =
  forall nsID extraState f s.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeInSub Namespace
NsStyle StyleName
"text-properties" forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
    ( forall (a :: * -> * -> *) z y x w v u r b.
Arrow a =>
(z -> y -> x -> w -> v -> u -> r)
-> a b z -> a b y -> a b x -> a b w -> a b v -> a b u -> a b r
liftA6 Bool
-> Bool
-> Maybe FontPitch
-> VerticalTextPosition
-> Maybe UnderlineMode
-> Maybe UnderlineMode
-> TextProperties
PropT
       ( forall nsID a extraState x.
NameSpaceID nsID =>
nsID
-> StyleName
-> a
-> [(StyleName, a)]
-> XMLConverter nsID extraState x a
searchAttr   Namespace
NsXSL_FO StyleName
"font-style"  Bool
False [(StyleName, Bool)]
isFontEmphasised )
       ( forall nsID a extraState x.
NameSpaceID nsID =>
nsID
-> StyleName
-> a
-> [(StyleName, a)]
-> XMLConverter nsID extraState x a
searchAttr   Namespace
NsXSL_FO StyleName
"font-weight" Bool
False [(StyleName, Bool)]
isFontBold       )
       forall _x. XMLReaderSafe FontPitches _x (Maybe FontPitch)
findPitch
       ( forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState x attrValue
getAttr      Namespace
NsStyle  StyleName
"text-position"                      )
       forall _x. StyleReaderSafe _x (Maybe UnderlineMode)
readUnderlineMode
       forall _x. StyleReaderSafe _x (Maybe UnderlineMode)
readStrikeThroughMode
     )
  where isFontEmphasised :: [(StyleName, Bool)]
isFontEmphasised = [(StyleName
"normal",Bool
False),(StyleName
"italic",Bool
True),(StyleName
"oblique",Bool
True)]
        isFontBold :: [(StyleName, Bool)]
isFontBold = (StyleName
"normal",Bool
False)forall a. a -> [a] -> [a]
:(StyleName
"bold",Bool
True)
                    forall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map ((,Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> StyleName
tshow) ([Int
100,Int
200..Int
900]::[Int])

readUnderlineMode     :: StyleReaderSafe _x (Maybe UnderlineMode)
readUnderlineMode :: forall _x. StyleReaderSafe _x (Maybe UnderlineMode)
readUnderlineMode     = forall _x.
StyleName -> StyleName -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode StyleName
"text-underline-mode"
                                     StyleName
"text-underline-style"

readStrikeThroughMode :: StyleReaderSafe _x (Maybe UnderlineMode)
readStrikeThroughMode :: forall _x. StyleReaderSafe _x (Maybe UnderlineMode)
readStrikeThroughMode = forall _x.
StyleName -> StyleName -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode StyleName
"text-line-through-mode"
                                     StyleName
"text-line-through-style"

readLineMode :: Text -> Text -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode :: forall _x.
StyleName -> StyleName -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode StyleName
modeAttr StyleName
styleAttr = proc _x
x -> do
  Bool
isUL <- forall nsID a extraState x.
NameSpaceID nsID =>
nsID
-> StyleName
-> a
-> [(StyleName, a)]
-> XMLConverter nsID extraState x a
searchAttr  Namespace
NsStyle StyleName
styleAttr Bool
False [(StyleName, Bool)]
isLinePresent -< _x
x
  Maybe UnderlineMode
mode <- forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> XMLConverter nsID extraState x (Maybe a)
lookupAttr' Namespace
NsStyle  StyleName
modeAttr                     -< _x
x
  if Bool
isUL
    then case Maybe UnderlineMode
mode of
           Just UnderlineMode
m  -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. a -> Maybe a
Just UnderlineMode
m
           Maybe UnderlineMode
Nothing -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. a -> Maybe a
Just UnderlineMode
UnderlineModeNormal
    else              forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Maybe a
Nothing
  where
    isLinePresent :: [(StyleName, Bool)]
isLinePresent = (StyleName
"none",Bool
False) forall a. a -> [a] -> [a]
: 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 _x ParaProperties
readParaProperties :: forall _x. StyleReader _x ParaProperties
readParaProperties =
   forall nsID extraState f s.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeInSub Namespace
NsStyle StyleName
"paragraph-properties" forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
     ( forall (a :: * -> * -> *) z y x r b.
Arrow a =>
(z -> y -> x -> r) -> a b z -> a b y -> a b x -> a b r
liftA3 ParaNumbering
-> LengthOrPercent -> LengthOrPercent -> ParaProperties
PropP
       ( forall (a :: * -> * -> *) x y z b.
Arrow a =>
(x -> y -> z) -> a b x -> a b y -> a b z
liftA2 Maybe Bool -> Maybe Int -> ParaNumbering
readNumbering
         ( forall nsID extraState x.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState x (Maybe Bool)
isSet'           Namespace
NsText   StyleName
"number-lines"           )
         ( forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue) =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe attrValue)
readAttr'        Namespace
NsText   StyleName
"line-number"            )
       )
       ( forall (a :: * -> * -> *) x y z b.
Arrow a =>
(x -> y -> z) -> a b x -> a b y -> a b z
liftA2 forall {p}. Default p => Bool -> p -> p
readIndentation
         ( forall nsID extraState x.
NameSpaceID nsID =>
nsID -> StyleName -> Bool -> XMLConverter nsID extraState x Bool
isSetWithDefault Namespace
NsStyle  StyleName
"auto-text-indent" Bool
False )
         ( forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState x attrValue
getAttr          Namespace
NsXSL_FO StyleName
"text-indent"            )
       )
       (   forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState x 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
_      = forall a. Default a => a
def

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

--
readListStyle :: StyleReader _x (StyleName, ListStyle)
readListStyle :: forall _x. StyleReader _x (StyleName, ListStyle)
readListStyle =
       forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x StyleName
findAttr Namespace
NsStyle StyleName
"name"
  forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue
       ( forall (a :: * -> * -> *) y z b.
Arrow a =>
(y -> z) -> a b y -> a b z
liftA Map Int ListLevelStyle -> ListStyle
ListStyle
         forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) z y x r b.
Arrow a =>
(z -> y -> x -> r) -> a b z -> a b y -> a b x -> a b r
liftA3 forall k v.
Ord k =>
SetMap k v -> SetMap k v -> SetMap k v -> SetMap k v
SM.union3
             ( forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
NsText StyleName
"list-level-style-number" ListLevelType
LltNumbered )
             ( forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
NsText StyleName
"list-level-style-bullet" ListLevelType
LltBullet   )
             ( forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
NsText StyleName
"list-level-style-image"  ListLevelType
LltImage    ) forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe Set ListLevelStyle -> Maybe ListLevelStyle
chooseMostSpecificListLevelStyle
       )
--
readListLevelStyles :: Namespace -> ElementName
                    -> ListLevelType
                    -> StyleReaderSafe _x (SM.SetMap Int ListLevelStyle)
readListLevelStyles :: forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
namespace StyleName
elementName ListLevelType
levelType =
  forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
namespace StyleName
elementName (forall _x. ListLevelType -> StyleReader _x (Int, ListLevelStyle)
readListLevelStyle ListLevelType
levelType)
    forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ forall k v. (Ord k, Ord v) => [(k, v)] -> SetMap k v
SM.fromList

--
readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle)
readListLevelStyle :: forall _x. ListLevelType -> StyleReader _x (Int, ListLevelStyle)
readListLevelStyle ListLevelType
levelType =      forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue) =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x attrValue
readAttr Namespace
NsText StyleName
"level"
                               forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue
                                    ( forall (a :: * -> * -> *) z y x w v r b.
Arrow a =>
(z -> y -> x -> w -> v -> r)
-> a b z -> a b y -> a b x -> a b w -> a b v -> a b r
liftA5 ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Maybe StyleName
-> ListLevelStyle
toListLevelStyle
                                      ( forall (a :: * -> * -> *) c x. Arrow a => c -> a x c
returnV       ListLevelType
levelType             )
                                      ( forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'     Namespace
NsStyle StyleName
"num-prefix"  )
                                      ( forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'     Namespace
NsStyle StyleName
"num-suffix"  )
                                      ( forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState x attrValue
getAttr       Namespace
NsStyle StyleName
"num-format"  )
                                      ( forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttrText' Namespace
NsText  StyleName
"start-value" )
                                    )
  where
  toListLevelStyle :: ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Maybe StyleName
-> ListLevelStyle
toListLevelStyle ListLevelType
_ 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 (forall {a}. (Num a, Read a) => Maybe StyleName -> a
startValue Maybe StyleName
b)
  toListLevelStyle ListLevelType
_ 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 (forall {a}. (Num a, Read a) => Maybe StyleName -> a
startValue Maybe StyleName
b)
  toListLevelStyle ListLevelType
t Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
f Maybe StyleName
b                = ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Int
-> ListLevelStyle
ListLevelStyle ListLevelType
t      Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
f (forall {a}. (Num a, Read a) => Maybe StyleName -> a
startValue Maybe StyleName
b)
  startValue :: Maybe StyleName -> a
startValue Maybe StyleName
mbx = forall a. a -> Maybe a -> a
fromMaybe a
1 (Maybe StyleName
mbx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ListLevelStyle -> Maybe ListLevelStyle -> Maybe ListLevelStyle
select forall a. Maybe a
Nothing Set ListLevelStyle
ls
  where
   select :: ListLevelStyle -> Maybe ListLevelStyle -> Maybe ListLevelStyle
select ListLevelStyle
l Maybe ListLevelStyle
Nothing = 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
_ ))
        =   forall a. a -> Maybe a
Just 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StyleName
p2) (Maybe StyleName
s1 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
defaultStyleMap :: Map StyleFamily StyleProperties
listStylesByName :: Map StyleName ListStyle
stylesByName :: Map StyleName Style
defaultStyleMap :: Styles -> Map StyleFamily StyleProperties
listStylesByName :: Styles -> Map StyleName ListStyle
stylesByName :: Styles -> Map StyleName 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
defaultStyleMap :: Map StyleFamily StyleProperties
listStylesByName :: Map StyleName ListStyle
stylesByName :: Map StyleName Style
defaultStyleMap :: Styles -> Map StyleFamily StyleProperties
listStylesByName :: Styles -> Map StyleName ListStyle
stylesByName :: Styles -> Map StyleName Style
..} StyleFamily
family = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def
                                        (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
defaultStyleMap :: Map StyleFamily StyleProperties
listStylesByName :: Map StyleName ListStyle
stylesByName :: Map StyleName Style
defaultStyleMap :: Styles -> Map StyleFamily StyleProperties
listStylesByName :: Styles -> Map StyleName ListStyle
stylesByName :: Styles -> Map StyleName Style
..} = 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.
parents               :: Style       -> Styles ->      [Style]
parents :: Style -> Styles -> [Style]
parents Style
style Styles
styles = forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Style -> Maybe (Style, Style)
findNextParent Style
style -- Ha!
  where findNextParent :: Style -> Maybe (Style, Style)
findNextParent Style{Maybe StyleName
Maybe StyleFamily
StyleProperties
styleProperties :: StyleProperties
listStyle :: Maybe StyleName
styleParentName :: Maybe StyleName
styleFamily :: Maybe StyleFamily
styleProperties :: Style -> StyleProperties
listStyle :: Style -> Maybe StyleName
styleParentName :: Style -> Maybe StyleName
styleFamily :: Style -> Maybe StyleFamily
..}
          = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: * -> * -> *) b. Arrow a => a b (b, b)
duplicate forall a b. (a -> b) -> a -> b
$ (StyleName -> Styles -> Maybe Style
`lookupStyle` Styles
styles) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe StyleName
styleParentName

-- | Looks up the style family of the current style. Normally, every style
-- should have one. But if not, all parents are searched.
getStyleFamily        :: Style       -> Styles -> Maybe StyleFamily
getStyleFamily :: Style -> Styles -> Maybe StyleFamily
getStyleFamily style :: Style
style@Style{Maybe StyleName
Maybe StyleFamily
StyleProperties
styleProperties :: StyleProperties
listStyle :: Maybe StyleName
styleParentName :: Maybe StyleName
styleFamily :: Maybe StyleFamily
styleProperties :: Style -> StyleProperties
listStyle :: Style -> Maybe StyleName
styleParentName :: Style -> Maybe StyleName
styleFamily :: Style -> Maybe StyleFamily
..} Styles
styles
  =     Maybe StyleFamily
styleFamily
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
F.asum (forall a b. (a -> b) -> [a] -> [b]
map (Style -> Styles -> Maybe StyleFamily
`getStyleFamily` Styles
styles) forall a b. (a -> b) -> a -> b
$ 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
  = forall a b. (a -> b) -> [a] -> [b]
map Style -> StyleProperties
styleProperties (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
                                                  forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList (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
                                                  forall a. [a] -> [a] -> [a]
++ [Style] -> Styles -> [StyleProperties]
extendedStylePropertyChain [Style]
trace Styles
styles