Hdoc/XML.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Hdoc.XML where
   4
   5 import Data.Default.Class (Default(..))
   6 import Data.Eq (Eq(..))
   7 import Data.Function ((.), on)
   8 import Data.Hashable (Hashable(..))
   9 import Data.Map.Strict (Map)
  10 import Data.Maybe (Maybe(..))
  11 import Data.Monoid (Monoid(..))
  12 import Data.Ord (Ord(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Sequence (Seq)
  15 import Data.String (IsString(..))
  16 import Text.Show (Show(..), showsPrec)
  17 import qualified Data.Sequence as Seq
  18 import qualified Data.Text.Lazy as TL
  19 import qualified Language.Symantic.XML as XML
  20
  21 import qualified Hdoc.TCT.Cell as TCT
  22 import Hdoc.Utils (Nat1)
  23
  24
  25 -- * Type 'Attrs'
  26 type Attrs = Map XML.QName (TCT.Cell TL.Text)
  27  -- TODO: Map -> HashMap?
  28
  29 -- * Type 'Pos'
  30 data Pos = Pos
  31  { pos_ancestors                :: Ancestors
  32  , pos_ancestorsWithFigureNames :: Ancestors
  33  , pos_precedingSiblings        :: Map XML.QName Rank
  34  } deriving (Eq,Show)
  35 instance Ord Pos where
  36         compare = compare`on`pos_ancestors
  37 -- | Return only the hash on 'pos_ancestors',
  38 -- which is unique because 'Ancestors'
  39 -- includes the 'Rank' of each 'Node'.
  40 instance Hashable Pos where
  41         hashWithSalt s Pos{..} =
  42                 s`hashWithSalt`pos_ancestors
  43 instance Default Pos where
  44         def = Pos mempty mempty mempty
  45
  46 -- ** Type 'Rank'
  47 -- | Nth child.
  48 type Rank = Nat1
  49
  50 -- ** Type 'Ancestors'
  51 type Ancestors = Seq (XML.QName, Rank)
  52
  53 ancestors :: Ancestors -> Maybe Ancestors
  54 ancestors p =
  55         case Seq.viewr p of
  56          Seq.EmptyR -> Nothing
  57          ls Seq.:> _ -> Just ls
  58
  59 -- * Type 'Ident'
  60 newtype Ident = Ident { unIdent :: TL.Text }
  61  deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
  62
  63 -- * Type 'URL'
  64 newtype URL = URL { unURL :: TL.Text }
  65  deriving (Eq,Ord,Default,Hashable)
  66 instance Show URL where
  67         showsPrec p = showsPrec p . unURL
  68 instance Semigroup URL where
  69         _x <> y = y