]> Git — Sourcephile - doclang.git/blob - Hdoc/XML.hs
fixup! Add PairAt, TokenAt and PlainAt.
[doclang.git] / Hdoc / XML.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Hdoc.XML where
5
6 import Data.Bool
7 import Data.Default.Class (Default(..))
8 import Data.Eq (Eq(..))
9 import Data.Function (($), (.), on)
10 import Data.Hashable (Hashable(..))
11 import Data.Map.Strict (Map)
12 import Data.Maybe (Maybe(..))
13 import Data.Monoid (Monoid(..))
14 import Data.Ord (Ord(..))
15 import Data.Semigroup (Semigroup(..))
16 import Data.Sequence (Seq)
17 import Data.String (IsString(..))
18 import Data.TreeSeq.Strict (Tree)
19 import Prelude (error)
20 import Text.Show (Show(..), showsPrec, showChar, showString)
21 import qualified Data.List as List
22 import qualified Data.Sequence as Seq
23 import qualified Data.Text.Lazy as TL
24
25 import qualified Hdoc.TCT.Cell as TCT
26 import Hdoc.TCT.Debug
27 import Hdoc.Utils (Nat1)
28
29 -- * Type 'XML'
30 type XML = Tree (TCT.Cell Node)
31 type XMLs = Seq XML
32
33 -- ** Type 'Name'
34 data Name = Name
35 { namePrefix :: TL.Text -- ^ eg. "xsl"
36 , nameSpace :: TL.Text -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
37 , nameLocal :: TL.Text -- ^ eg. "stylesheet"
38 }
39 instance Show Name where
40 showsPrec _p Name{nameSpace="", ..} =
41 showString (TL.unpack nameLocal)
42 showsPrec _p Name{..} =
43 if TL.null nameSpace
44 then showString (TL.unpack nameLocal)
45 else
46 showChar '{' .
47 showString (TL.unpack nameSpace) .
48 showChar '}' .
49 showString (TL.unpack nameLocal)
50 instance Eq Name where
51 Name _ sx lx == Name _ sy ly = sx == sy && lx == ly
52 instance Ord Name where
53 Name _ sx lx `compare` Name _ sy ly = compare sx sy <> compare lx ly
54 instance IsString Name where
55 fromString "" = Name "" "" ""
56 fromString full@('{':rest) =
57 case List.break (== '}') rest of
58 (_, "") -> error ("Invalid Clark notation: " <> show full)
59 (ns, local) -> Name "" (TL.pack ns) (TL.pack $ List.drop 1 local)
60 fromString local = Name "" "" (TL.pack local)
61 instance Pretty Name
62 instance Hashable Name where
63 hashWithSalt s Name{..} =
64 s`hashWithSalt`namePrefix
65 `hashWithSalt`nameSpace
66 `hashWithSalt`nameLocal
67
68 localName :: TL.Text -> Name
69 localName = Name "" ""
70
71 -- ** Type 'Node'
72 data Node
73 = NodeElem Name
74 | NodeAttr Name TL.Text
75 | NodeText TL.Text
76 | NodeComment TL.Text
77 deriving (Eq,Ord,Show)
78 instance Pretty Node
79
80 -- ** Type 'Attrs'
81 type Attrs = Map Name (TCT.Cell TL.Text)
82
83 -- * Type 'Pos'
84 data Pos = Pos
85 { pos_ancestors :: Ancestors
86 , pos_ancestorsWithFigureNames :: Ancestors
87 , pos_precedingSiblings :: Map Name Rank
88 } deriving (Eq,Show)
89 instance Ord Pos where
90 compare = compare`on`pos_ancestors
91 -- | Return only the hash on 'pos_ancestors',
92 -- which is unique because 'Ancestors'
93 -- includes the 'Rank' of each 'Node'.
94 instance Hashable Pos where
95 hashWithSalt s Pos{..} =
96 s`hashWithSalt`pos_ancestors
97 instance Default Pos where
98 def = Pos mempty mempty mempty
99
100 -- ** Type 'Rank'
101 -- | Nth child.
102 type Rank = Nat1
103
104 -- ** Type 'Ancestors'
105 type Ancestors = Seq (Name, Rank)
106
107 ancestors :: Ancestors -> Maybe Ancestors
108 ancestors p =
109 case Seq.viewr p of
110 Seq.EmptyR -> Nothing
111 ls Seq.:> _ -> Just ls
112
113 -- * Type 'Ident'
114 newtype Ident = Ident { unIdent :: TL.Text }
115 deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
116
117 -- * Type 'URL'
118 newtype URL = URL { unURL :: TL.Text }
119 deriving (Eq,Ord,Default,Hashable)
120 instance Show URL where
121 showsPrec p = showsPrec p . unURL
122 instance Semigroup URL where
123 _x <> y = y