]> Git — Sourcephile - doclang.git/blob - Hdoc/XML.hs
TCT: fix comment
[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 -- TODO: Map -> HashMap?
83
84 -- * Type 'Pos'
85 data Pos = Pos
86 { pos_ancestors :: Ancestors
87 , pos_ancestorsWithFigureNames :: Ancestors
88 , pos_precedingSiblings :: Map Name Rank
89 } deriving (Eq,Show)
90 instance Ord Pos where
91 compare = compare`on`pos_ancestors
92 -- | Return only the hash on 'pos_ancestors',
93 -- which is unique because 'Ancestors'
94 -- includes the 'Rank' of each 'Node'.
95 instance Hashable Pos where
96 hashWithSalt s Pos{..} =
97 s`hashWithSalt`pos_ancestors
98 instance Default Pos where
99 def = Pos mempty mempty mempty
100
101 -- ** Type 'Rank'
102 -- | Nth child.
103 type Rank = Nat1
104
105 -- ** Type 'Ancestors'
106 type Ancestors = Seq (Name, Rank)
107
108 ancestors :: Ancestors -> Maybe Ancestors
109 ancestors p =
110 case Seq.viewr p of
111 Seq.EmptyR -> Nothing
112 ls Seq.:> _ -> Just ls
113
114 -- * Type 'Ident'
115 newtype Ident = Ident { unIdent :: TL.Text }
116 deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
117
118 -- * Type 'URL'
119 newtype URL = URL { unURL :: TL.Text }
120 deriving (Eq,Ord,Default,Hashable)
121 instance Show URL where
122 showsPrec p = showsPrec p . unURL
123 instance Semigroup URL where
124 _x <> y = y