Hdoc/XML.hs

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