]> Git — Sourcephile - doclang.git/blob - Hdoc/XML.hs
Update to megaparsec-7 and new symantic-xml
[doclang.git] / 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 Language.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