{-# 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 = FallibleXMLConverter Namespace FontPitches () Styles
-> FontPitches -> Element -> Fallible Styles
forall nsID extraState success.
NameSpaceID nsID =>
FallibleXMLConverter nsID extraState () success
-> extraState -> Element -> Fallible success
runConverter' FallibleXMLConverter Namespace FontPitches () Styles
forall _x. StyleReader _x 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 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 = Namespace
-> StyleName
-> FallibleXMLConverter Namespace _s _x FontPitches
-> FallibleXMLConverter Namespace _s _x FontPitches
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" (
                          Namespace
-> StyleName
-> FallibleXMLConverter
     Namespace _s _x (Maybe StyleName, FontPitch)
-> FallibleXMLConverter
     Namespace _s _x [(Maybe StyleName, FontPitch)]
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" (ArrowState
  (XMLConverterState Namespace _s) _x (Maybe StyleName, FontPitch)
-> FallibleXMLConverter
     Namespace _s _x (Maybe StyleName, FontPitch)
forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess (
                              Namespace
-> StyleName -> XMLConverter Namespace _s _x (Maybe StyleName)
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr' Namespace
NsStyle StyleName
"name"
                              XMLConverter Namespace _s _x (Maybe StyleName)
-> ArrowState (XMLConverterState Namespace _s) _x FontPitch
-> ArrowState
     (XMLConverterState Namespace _s) _x (Maybe StyleName, FontPitch)
forall b c c'.
ArrowState (XMLConverterState Namespace _s) b c
-> ArrowState (XMLConverterState Namespace _s) b c'
-> ArrowState (XMLConverterState Namespace _s) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
                              Namespace
-> StyleName
-> ArrowState (XMLConverterState Namespace _s) _x FontPitch
forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a, Default a) =>
nsID -> StyleName -> XMLConverter nsID extraState x a
lookupDefaultingAttr Namespace
NsStyle StyleName
"font-pitch"
                            ))
                    FallibleXMLConverter Namespace _s _x [(Maybe StyleName, FontPitch)]
-> ([(Maybe StyleName, FontPitch)] -> FontPitches)
-> FallibleXMLConverter Namespace _s _x FontPitches
forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> (success -> success') -> FallibleArrow a x failure success'
>>?^ ( [(StyleName, FontPitch)] -> FontPitches
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StyleName, FontPitch)] -> FontPitches)
-> ([(Maybe StyleName, FontPitch)] -> [(StyleName, FontPitch)])
-> [(Maybe StyleName, FontPitch)]
-> FontPitches
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(StyleName, FontPitch)]
 -> (Maybe StyleName, FontPitch) -> [(StyleName, FontPitch)])
-> [(StyleName, FontPitch)]
-> [(Maybe StyleName, FontPitch)]
-> [(StyleName, FontPitch)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(StyleName, FontPitch)]
-> (Maybe StyleName, FontPitch) -> [(StyleName, FontPitch)]
forall {a} {b}. [(a, b)] -> (Maybe a, b) -> [(a, b)]
accumLegalPitches [] )
                  ) FallibleXMLConverter Namespace _s _x FontPitches
-> FallibleXMLConverter Namespace _s _x FontPitches
-> FallibleXMLConverter Namespace _s _x FontPitches
forall (a :: * -> * -> *) x f y.
ArrowChoice a =>
FallibleArrow a x f y
-> FallibleArrow a x f y -> FallibleArrow a x f y
`ifFailedDo` Either () FontPitches
-> FallibleXMLConverter Namespace _s _x FontPitches
forall (a :: * -> * -> *) c x. Arrow a => c -> a x c
returnV (FontPitches -> Either () FontPitches
forall a b. b -> Either a b
Right FontPitches
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)(a, b) -> [(a, b)] -> [(a, b)]
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 = ()
-> ()
-> FallibleXMLConverter Namespace () () FontPitches
-> FallibleXMLConverter Namespace FontPitches x x
forall extraState' a nsID extraState x.
extraState'
-> a
-> FallibleXMLConverter nsID extraState' a extraState
-> FallibleXMLConverter nsID extraState x x
producingExtraState () () FallibleXMLConverter Namespace () () FontPitches
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 =     ( Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x FontPitch
forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> FallibleXMLConverter nsID extraState x a
lookupAttr Namespace
NsStyle StyleName
"font-pitch"
                  FallibleXMLConverter Namespace FontPitches _x FontPitch
-> FallibleXMLConverter Namespace FontPitches _x FontPitch
-> FallibleXMLConverter Namespace FontPitches _x FontPitch
forall (a :: * -> * -> *) x f y.
ArrowChoice a =>
FallibleArrow a x f y
-> FallibleArrow a x f y -> FallibleArrow a x f y
`ifFailedDo`     Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x StyleName
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x StyleName
findAttr Namespace
NsStyle StyleName
"font-name"
                               FallibleXMLConverter Namespace FontPitches _x StyleName
-> FallibleArrow
     (ArrowState (XMLConverterState Namespace FontPitches))
     StyleName
     ()
     FontPitch
-> FallibleXMLConverter Namespace FontPitches _x FontPitch
forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> FallibleArrow a success failure success'
-> FallibleArrow a x failure success'
>>? (     ArrowState
  (XMLConverterState Namespace FontPitches) StyleName FontPitches
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (StyleName, FontPitches)
forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue ArrowState
  (XMLConverterState Namespace FontPitches) StyleName FontPitches
forall nsID extraState x. XMLConverter nsID extraState x extraState
getExtraState
                                     ArrowState
  (XMLConverterState Namespace FontPitches)
  StyleName
  (StyleName, FontPitches)
-> (StyleName -> FontPitches -> Maybe FontPitch)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe FontPitch)
forall (a :: * -> * -> *) x b c d.
Arrow a =>
a x (b, c) -> (b -> c -> d) -> a x d
>>% StyleName -> FontPitches -> Maybe FontPitch
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup
                                     ArrowState
  (XMLConverterState Namespace FontPitches)
  StyleName
  (Maybe FontPitch)
-> (Maybe FontPitch -> Either () FontPitch)
-> FallibleArrow
     (ArrowState (XMLConverterState Namespace FontPitches))
     StyleName
     ()
     FontPitch
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ Maybe FontPitch -> Either () FontPitch
forall (a :: * -> * -> *) b.
ArrowChoice a =>
a (Maybe b) (Fallible b)
maybeToChoice
                                   )
                )
            FallibleXMLConverter Namespace FontPitches _x FontPitch
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     (Either () FontPitch)
     (Maybe FontPitch)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe FontPitch)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ArrowState
  (XMLConverterState Namespace FontPitches)
  (Either () FontPitch)
  (Maybe FontPitch)
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
(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 _x Styles
readAllStyles :: forall _x. StyleReader _x Styles
readAllStyles = (      StyleReader _x _x
forall x. StyleReader x x
readFontPitches
                  StyleReader _x _x
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Fallible Styles, Fallible Styles)
-> FallibleArrow
     (ArrowState (XMLConverterState Namespace FontPitches))
     _x
     ()
     (Fallible Styles, Fallible Styles)
forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! (     StyleReader _x Styles
forall _x. StyleReader _x Styles
readAutomaticStyles
                         StyleReader _x Styles
-> StyleReader _x Styles
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Fallible Styles, Fallible Styles)
forall b c c'.
ArrowState (XMLConverterState Namespace FontPitches) b c
-> ArrowState (XMLConverterState Namespace FontPitches) b c'
-> ArrowState (XMLConverterState Namespace FontPitches) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StyleReader _x Styles
forall _x. StyleReader _x Styles
readStyles ))
                  FallibleArrow
  (ArrowState (XMLConverterState Namespace FontPitches))
  _x
  ()
  (Fallible Styles, Fallible Styles)
-> (Fallible Styles -> Fallible Styles -> Fallible Styles)
-> StyleReader _x Styles
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
>>?%? Fallible Styles -> Fallible Styles -> Fallible Styles
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 = Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall nsID extraState f s.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState f s
-> FallibleXMLConverter nsID extraState f s
executeInSub Namespace
NsOffice StyleName
"styles" (FallibleXMLConverter Namespace FontPitches _x Styles
 -> FallibleXMLConverter Namespace FontPitches _x Styles)
-> FallibleXMLConverter Namespace FontPitches _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall a b. (a -> b) -> a -> b
$ ArrowState (XMLConverterState Namespace FontPitches) _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
  (ArrowState (XMLConverterState Namespace FontPitches) _x Styles
 -> FallibleXMLConverter Namespace FontPitches _x Styles)
-> ArrowState (XMLConverterState Namespace FontPitches) _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall a b. (a -> b) -> a -> b
$ (Map StyleName Style
 -> Map StyleName ListStyle
 -> Map StyleFamily StyleProperties
 -> Styles)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Map StyleName Style)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleName ListStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleFamily StyleProperties)
-> ArrowState (XMLConverterState Namespace FontPitches) _x Styles
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
    ( Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x (StyleName, Style)
-> XMLConverter Namespace FontPitches _x [(StyleName, Style)]
forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsStyle StyleName
"style"         FallibleXMLConverter Namespace FontPitches _x (StyleName, Style)
forall _x. StyleReader _x (StyleName, Style)
readStyle        XMLConverter Namespace FontPitches _x [(StyleName, Style)]
-> ([(StyleName, Style)] -> Map StyleName Style)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Map StyleName Style)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [(StyleName, Style)] -> Map StyleName Style
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( Namespace
-> StyleName
-> FallibleXMLConverter
     Namespace FontPitches _x (StyleName, ListStyle)
-> XMLConverter Namespace FontPitches _x [(StyleName, ListStyle)]
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"    FallibleXMLConverter
  Namespace FontPitches _x (StyleName, ListStyle)
forall _x. StyleReader _x (StyleName, ListStyle)
readListStyle    XMLConverter Namespace FontPitches _x [(StyleName, ListStyle)]
-> ([(StyleName, ListStyle)] -> Map StyleName ListStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleName ListStyle)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [(StyleName, ListStyle)] -> Map StyleName ListStyle
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( Namespace
-> StyleName
-> FallibleXMLConverter
     Namespace FontPitches _x (StyleFamily, StyleProperties)
-> XMLConverter
     Namespace FontPitches _x [(StyleFamily, StyleProperties)]
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" FallibleXMLConverter
  Namespace FontPitches _x (StyleFamily, StyleProperties)
forall _x. StyleReader _x (StyleFamily, StyleProperties)
readDefaultStyle XMLConverter
  Namespace FontPitches _x [(StyleFamily, StyleProperties)]
-> ([(StyleFamily, StyleProperties)]
    -> Map StyleFamily StyleProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleFamily StyleProperties)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [(StyleFamily, StyleProperties)] -> Map StyleFamily StyleProperties
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )

--
readAutomaticStyles :: StyleReader _x Styles
readAutomaticStyles :: forall _x. StyleReader _x Styles
readAutomaticStyles = Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
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" (FallibleXMLConverter Namespace FontPitches _x Styles
 -> FallibleXMLConverter Namespace FontPitches _x Styles)
-> FallibleXMLConverter Namespace FontPitches _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall a b. (a -> b) -> a -> b
$ ArrowState (XMLConverterState Namespace FontPitches) _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
  (ArrowState (XMLConverterState Namespace FontPitches) _x Styles
 -> FallibleXMLConverter Namespace FontPitches _x Styles)
-> ArrowState (XMLConverterState Namespace FontPitches) _x Styles
-> FallibleXMLConverter Namespace FontPitches _x Styles
forall a b. (a -> b) -> a -> b
$ (Map StyleName Style
 -> Map StyleName ListStyle
 -> Map StyleFamily StyleProperties
 -> Styles)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Map StyleName Style)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleName ListStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleFamily StyleProperties)
-> ArrowState (XMLConverterState Namespace FontPitches) _x Styles
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
    ( Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x (StyleName, Style)
-> XMLConverter Namespace FontPitches _x [(StyleName, Style)]
forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
NsStyle StyleName
"style"         FallibleXMLConverter Namespace FontPitches _x (StyleName, Style)
forall _x. StyleReader _x (StyleName, Style)
readStyle        XMLConverter Namespace FontPitches _x [(StyleName, Style)]
-> ([(StyleName, Style)] -> Map StyleName Style)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Map StyleName Style)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [(StyleName, Style)] -> Map StyleName Style
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( Namespace
-> StyleName
-> FallibleXMLConverter
     Namespace FontPitches _x (StyleName, ListStyle)
-> XMLConverter Namespace FontPitches _x [(StyleName, ListStyle)]
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"    FallibleXMLConverter
  Namespace FontPitches _x (StyleName, ListStyle)
forall _x. StyleReader _x (StyleName, ListStyle)
readListStyle    XMLConverter Namespace FontPitches _x [(StyleName, ListStyle)]
-> ([(StyleName, ListStyle)] -> Map StyleName ListStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleName ListStyle)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [(StyleName, ListStyle)] -> Map StyleName ListStyle
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList )
    ( Map StyleFamily StyleProperties
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (Map StyleFamily StyleProperties)
forall (a :: * -> * -> *) c x. Arrow a => c -> a x c
returnV Map StyleFamily StyleProperties
forall k a. Map k a
M.empty                                                )

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

--
readStyle :: StyleReader _x (StyleName,Style)
readStyle :: forall _x. StyleReader _x (StyleName, Style)
readStyle =      Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x StyleName
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x StyleName
findAttr Namespace
NsStyle StyleName
"name"
            FallibleXMLConverter Namespace FontPitches _x StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (StyleName, Style)
-> FallibleArrow
     (ArrowState (XMLConverterState Namespace FontPitches))
     _x
     ()
     (StyleName, Style)
forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! ArrowState
  (XMLConverterState Namespace FontPitches) StyleName Style
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (StyleName, Style)
forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue
                   ( (Maybe StyleFamily
 -> Maybe StyleName -> Maybe StyleName -> StyleProperties -> Style)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe StyleFamily)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe StyleName)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe StyleName)
-> ArrowState
     (XMLConverterState Namespace FontPitches) StyleName StyleProperties
-> ArrowState
     (XMLConverterState Namespace FontPitches) StyleName Style
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
                       ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe StyleFamily)
forall nsID a extraState x.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> XMLConverter nsID extraState x (Maybe a)
lookupAttr' Namespace
NsStyle StyleName
"family"            )
                       ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe StyleName)
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'   Namespace
NsStyle StyleName
"parent-style-name" )
                       ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Maybe StyleName)
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'   Namespace
NsStyle StyleName
"list-style-name"   )
                       ArrowState
  (XMLConverterState Namespace FontPitches) StyleName StyleProperties
forall _x. StyleReaderSafe _x StyleProperties
readStyleProperties
                   )

--
readStyleProperties :: StyleReaderSafe _x StyleProperties
readStyleProperties :: forall _x. StyleReaderSafe _x StyleProperties
readStyleProperties = (Maybe TextProperties -> Maybe ParaProperties -> StyleProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe TextProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe ParaProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x StyleProperties
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
                       ( StyleReader _x TextProperties
forall _x. StyleReader _x TextProperties
readTextProperties StyleReader _x TextProperties
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     (Fallible TextProperties)
     (Maybe TextProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe TextProperties)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ArrowState
  (XMLConverterState Namespace FontPitches)
  (Fallible TextProperties)
  (Maybe TextProperties)
forall (a :: * -> * -> *) l r.
ArrowChoice a =>
a (Either l r) (Maybe r)
choiceToMaybe )
                       ( StyleReader _x ParaProperties
forall _x. StyleReader _x ParaProperties
readParaProperties StyleReader _x ParaProperties
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     (Fallible ParaProperties)
     (Maybe ParaProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe ParaProperties)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ArrowState
  (XMLConverterState Namespace FontPitches)
  (Fallible ParaProperties)
  (Maybe ParaProperties)
forall (a :: * -> * -> *) l r.
ArrowChoice a =>
a (Either l r) (Maybe r)
choiceToMaybe )

--
readTextProperties :: StyleReader _x TextProperties
readTextProperties :: forall _x. StyleReader _x TextProperties
readTextProperties =
  Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x TextProperties
-> FallibleXMLConverter Namespace FontPitches _x TextProperties
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" (FallibleXMLConverter Namespace FontPitches _x TextProperties
 -> FallibleXMLConverter Namespace FontPitches _x TextProperties)
-> FallibleXMLConverter Namespace FontPitches _x TextProperties
-> FallibleXMLConverter Namespace FontPitches _x TextProperties
forall a b. (a -> b) -> a -> b
$ ArrowState
  (XMLConverterState Namespace FontPitches) _x TextProperties
-> FallibleXMLConverter Namespace FontPitches _x TextProperties
forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
    ( (Bool
 -> Bool
 -> Maybe FontPitch
 -> VerticalTextPosition
 -> Maybe UnderlineMode
 -> Maybe UnderlineMode
 -> TextProperties)
-> ArrowState (XMLConverterState Namespace FontPitches) _x Bool
-> ArrowState (XMLConverterState Namespace FontPitches) _x Bool
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe FontPitch)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x VerticalTextPosition
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe UnderlineMode)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe UnderlineMode)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x TextProperties
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
       ( Namespace
-> StyleName
-> Bool
-> [(StyleName, Bool)]
-> ArrowState (XMLConverterState Namespace FontPitches) _x Bool
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 )
       ( Namespace
-> StyleName
-> Bool
-> [(StyleName, Bool)]
-> ArrowState (XMLConverterState Namespace FontPitches) _x Bool
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       )
       ArrowState
  (XMLConverterState Namespace FontPitches) _x (Maybe FontPitch)
forall _x. XMLReaderSafe FontPitches _x (Maybe FontPitch)
findPitch
       ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x VerticalTextPosition
forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState x attrValue
getAttr      Namespace
NsStyle  StyleName
"text-position"                      )
       ArrowState
  (XMLConverterState Namespace FontPitches) _x (Maybe UnderlineMode)
forall _x. StyleReaderSafe _x (Maybe UnderlineMode)
readUnderlineMode
       ArrowState
  (XMLConverterState Namespace FontPitches) _x (Maybe UnderlineMode)
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)(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 ((,Bool
True) (StyleName -> (StyleName, Bool))
-> (Int -> StyleName) -> Int -> (StyleName, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StyleName
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     = StyleName -> StyleName -> StyleReaderSafe _x (Maybe UnderlineMode)
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 = StyleName -> StyleName -> StyleReaderSafe _x (Maybe UnderlineMode)
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 <- Namespace
-> StyleName
-> Bool
-> [(StyleName, Bool)]
-> XMLConverter Namespace FontPitches _x Bool
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 <- Namespace
-> StyleName
-> XMLConverter Namespace FontPitches _x (Maybe UnderlineMode)
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  -> ArrowState
  (XMLConverterState Namespace FontPitches)
  (Maybe UnderlineMode)
  (Maybe UnderlineMode)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< UnderlineMode -> Maybe UnderlineMode
forall a. a -> Maybe a
Just UnderlineMode
m
           Maybe UnderlineMode
Nothing -> ArrowState
  (XMLConverterState Namespace FontPitches)
  (Maybe UnderlineMode)
  (Maybe UnderlineMode)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< UnderlineMode -> Maybe UnderlineMode
forall a. a -> Maybe a
Just UnderlineMode
UnderlineModeNormal
    else              ArrowState
  (XMLConverterState Namespace FontPitches)
  (Maybe UnderlineMode)
  (Maybe UnderlineMode)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Maybe UnderlineMode
forall a. Maybe a
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 _x ParaProperties
readParaProperties :: forall _x. StyleReader _x ParaProperties
readParaProperties =
   Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x ParaProperties
-> FallibleXMLConverter Namespace FontPitches _x ParaProperties
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" (FallibleXMLConverter Namespace FontPitches _x ParaProperties
 -> FallibleXMLConverter Namespace FontPitches _x ParaProperties)
-> FallibleXMLConverter Namespace FontPitches _x ParaProperties
-> FallibleXMLConverter Namespace FontPitches _x ParaProperties
forall a b. (a -> b) -> a -> b
$ ArrowState
  (XMLConverterState Namespace FontPitches) _x ParaProperties
-> FallibleXMLConverter Namespace FontPitches _x ParaProperties
forall (a :: * -> * -> *) x success failure.
ArrowChoice a =>
a x success -> FallibleArrow a x failure success
liftAsSuccess
     ( (ParaNumbering
 -> LengthOrPercent -> LengthOrPercent -> ParaProperties)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x ParaNumbering
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x LengthOrPercent
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x LengthOrPercent
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x ParaProperties
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
       ( (Maybe Bool -> Maybe Int -> ParaNumbering)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe Bool)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe Int)
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x ParaNumbering
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
         ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe Bool)
forall nsID extraState x.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState x (Maybe Bool)
isSet'           Namespace
NsText   StyleName
"number-lines"           )
         ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x (Maybe Int)
forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue) =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe attrValue)
readAttr'        Namespace
NsText   StyleName
"line-number"            )
       )
       ( (Bool -> LengthOrPercent -> LengthOrPercent)
-> ArrowState (XMLConverterState Namespace FontPitches) _x Bool
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x LengthOrPercent
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x LengthOrPercent
forall (a :: * -> * -> *) x y z b.
Arrow a =>
(x -> y -> z) -> a b x -> a b y -> a b z
liftA2 Bool -> LengthOrPercent -> LengthOrPercent
forall {p}. Default p => Bool -> p -> p
readIndentation
         ( Namespace
-> StyleName
-> Bool
-> ArrowState (XMLConverterState Namespace FontPitches) _x Bool
forall nsID extraState x.
NameSpaceID nsID =>
nsID -> StyleName -> Bool -> XMLConverter nsID extraState x Bool
isSetWithDefault Namespace
NsStyle  StyleName
"auto-text-indent" Bool
False )
         ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x LengthOrPercent
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"            )
       )
       (   Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) _x LengthOrPercent
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
_      = p
forall a. Default a => a
def

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

--
readListStyle :: StyleReader _x (StyleName, ListStyle)
readListStyle :: forall _x. StyleReader _x (StyleName, ListStyle)
readListStyle =
       Namespace
-> StyleName
-> FallibleXMLConverter Namespace FontPitches _x StyleName
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x StyleName
findAttr Namespace
NsStyle StyleName
"name"
  FallibleXMLConverter Namespace FontPitches _x StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (StyleName, ListStyle)
-> FallibleArrow
     (ArrowState (XMLConverterState Namespace FontPitches))
     _x
     ()
     (StyleName, ListStyle)
forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! ArrowState
  (XMLConverterState Namespace FontPitches) StyleName ListStyle
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (StyleName, ListStyle)
forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue
       ( (Map Int ListLevelStyle -> ListStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Map Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches) StyleName ListStyle
forall (a :: * -> * -> *) y z b.
Arrow a =>
(y -> z) -> a b y -> a b z
liftA Map Int ListLevelStyle -> ListStyle
ListStyle
         (ArrowState
   (XMLConverterState Namespace FontPitches)
   StyleName
   (Map Int ListLevelStyle)
 -> ArrowState
      (XMLConverterState Namespace FontPitches) StyleName ListStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Map Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches) StyleName ListStyle
forall a b. (a -> b) -> a -> b
$ (SetMap Int ListLevelStyle
 -> SetMap Int ListLevelStyle
 -> SetMap Int ListLevelStyle
 -> SetMap Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
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 SetMap Int ListLevelStyle
-> SetMap Int ListLevelStyle
-> SetMap Int ListLevelStyle
-> SetMap Int ListLevelStyle
forall k v.
Ord k =>
SetMap k v -> SetMap k v -> SetMap k v -> SetMap k v
SM.union3
             ( Namespace
-> StyleName
-> ListLevelType
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
NsText StyleName
"list-level-style-number" ListLevelType
LltNumbered )
             ( Namespace
-> StyleName
-> ListLevelType
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
NsText StyleName
"list-level-style-bullet" ListLevelType
LltBullet   )
             ( Namespace
-> StyleName
-> ListLevelType
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (SetMap Int ListLevelStyle)
forall _x.
Namespace
-> StyleName
-> ListLevelType
-> StyleReaderSafe _x (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
NsText StyleName
"list-level-style-image"  ListLevelType
LltImage    ) ArrowState
  (XMLConverterState Namespace FontPitches)
  StyleName
  (SetMap Int ListLevelStyle)
-> (SetMap Int ListLevelStyle -> Map Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     StyleName
     (Map Int ListLevelStyle)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ (Set ListLevelStyle -> Maybe ListLevelStyle)
-> SetMap Int ListLevelStyle -> Map Int ListLevelStyle
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 =
  Namespace
-> StyleName
-> FallibleXMLConverter
     Namespace FontPitches _x (Int, ListLevelStyle)
-> XMLConverter Namespace FontPitches _x [(Int, ListLevelStyle)]
forall nsID extraState b a.
NameSpaceID nsID =>
nsID
-> StyleName
-> FallibleXMLConverter nsID extraState b a
-> XMLConverter nsID extraState b [a]
tryAll Namespace
namespace StyleName
elementName (ListLevelType
-> FallibleXMLConverter
     Namespace FontPitches _x (Int, ListLevelStyle)
forall _x. ListLevelType -> StyleReader _x (Int, ListLevelStyle)
readListLevelStyle ListLevelType
levelType)
    XMLConverter Namespace FontPitches _x [(Int, ListLevelStyle)]
-> ([(Int, ListLevelStyle)] -> SetMap Int ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches)
     _x
     (SetMap Int ListLevelStyle)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ [(Int, ListLevelStyle)] -> SetMap Int ListLevelStyle
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 =      Namespace
-> StyleName -> FallibleXMLConverter Namespace FontPitches _x Int
forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue) =>
nsID
-> StyleName -> FallibleXMLConverter nsID extraState x attrValue
readAttr Namespace
NsText StyleName
"level"
                               FallibleXMLConverter Namespace FontPitches _x Int
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Int, ListLevelStyle)
-> FallibleArrow
     (ArrowState (XMLConverterState Namespace FontPitches))
     _x
     ()
     (Int, ListLevelStyle)
forall (a :: * -> * -> *) x failure success success'.
ArrowChoice a =>
FallibleArrow a x failure success
-> a success success' -> FallibleArrow a x failure success'
>>?! ArrowState
  (XMLConverterState Namespace FontPitches) Int ListLevelStyle
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Int, ListLevelStyle)
forall (a :: * -> * -> *) b c. Arrow a => a b c -> a b (b, c)
keepingTheValue
                                    ( (ListLevelType
 -> Maybe StyleName
 -> Maybe StyleName
 -> ListItemNumberFormat
 -> Maybe StyleName
 -> ListLevelStyle)
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int ListLevelType
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Maybe StyleName)
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Maybe StyleName)
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int ListItemNumberFormat
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Maybe StyleName)
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int ListLevelStyle
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
                                      ( ListLevelType
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int ListLevelType
forall (a :: * -> * -> *) c x. Arrow a => c -> a x c
returnV       ListLevelType
levelType             )
                                      ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Maybe StyleName)
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'     Namespace
NsStyle StyleName
"num-prefix"  )
                                      ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Maybe StyleName)
forall nsID extraState x.
NameSpaceID nsID =>
nsID
-> StyleName -> XMLConverter nsID extraState x (Maybe StyleName)
findAttr'     Namespace
NsStyle StyleName
"num-suffix"  )
                                      ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int ListItemNumberFormat
forall nsID attrValue extraState x.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState x attrValue
getAttr       Namespace
NsStyle StyleName
"num-format"  )
                                      ( Namespace
-> StyleName
-> ArrowState
     (XMLConverterState Namespace FontPitches) Int (Maybe StyleName)
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 (Maybe StyleName -> Int
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 (Maybe StyleName -> Int
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 (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.
parents               :: Style       -> Styles ->      [Style]
parents :: Style -> Styles -> [Style]
parents Style
style Styles
styles = (Style -> Maybe (Style, Style)) -> Style -> [Style]
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
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
..}
          = (Style -> (Style, Style)) -> Maybe Style -> Maybe (Style, Style)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Style -> (Style, Style)
forall (a :: * -> * -> *) b. Arrow a => a b (b, b)
duplicate (Maybe Style -> Maybe (Style, Style))
-> Maybe Style -> Maybe (Style, Style)
forall a b. (a -> b) -> a -> b
$ (StyleName -> Styles -> Maybe Style
`lookupStyle` Styles
styles) (StyleName -> Maybe Style) -> Maybe StyleName -> Maybe Style
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
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
..} Styles
styles
  =     Maybe StyleFamily
styleFamily
    Maybe StyleFamily -> Maybe StyleFamily -> Maybe StyleFamily
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Maybe StyleFamily] -> Maybe StyleFamily
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
F.asum ((Style -> Maybe StyleFamily) -> [Style] -> [Maybe StyleFamily]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> Styles -> Maybe StyleFamily
`getStyleFamily` Styles
styles) ([Style] -> [Maybe StyleFamily]) -> [Style] -> [Maybe StyleFamily]
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
  = (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