1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Language.XML where
6 import Control.Applicative (Applicative(..))
8 import Data.Default.Class (Default(..))
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.))
12 import Data.Map.Strict (Map)
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.Text (Text)
19 import Data.TreeSeq.Strict (Tree)
20 import Prelude (error)
21 import Text.Show (Show(..), showsPrec, showChar, showString)
22 import qualified Data.List as List
23 import qualified Data.Text as Text
25 import Language.TCT.Cell
28 type XML = Tree (Cell XmlName) (Cell XmlLeaf)
34 { xmlNamePrefix :: Text
35 , xmlNameSpace :: Text
36 , xmlNameLocal :: Text
38 instance Show XmlName where
39 showsPrec _p XmlName{xmlNameSpace="", ..} =
40 showString (Text.unpack xmlNameLocal)
41 showsPrec _p XmlName{..} =
42 if Text.null xmlNameSpace
43 then showString (Text.unpack xmlNameLocal)
46 showString (Text.unpack xmlNameSpace) .
48 showString (Text.unpack xmlNameLocal)
49 instance Eq XmlName where
50 XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
51 instance Ord XmlName where
52 XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
53 instance IsString XmlName where
54 fromString "" = XmlName "" "" ""
55 fromString full@('{':rest) =
56 case List.break (== '}') rest of
57 (_, "") -> error ("Invalid Clark notation: " <> show full)
58 (ns, local) -> XmlName "" (Text.pack ns) (Text.pack $ List.drop 1 local)
59 fromString local = XmlName "" "" (Text.pack local)
61 xmlLocalName :: Text -> XmlName
62 xmlLocalName = XmlName "" ""
66 = XmlAttr XmlName Text
69 deriving (Eq,Ord,Show)
74 { xmlPosAncestors :: [(XmlName,Count)]
75 , xmlPosPrecedingsSiblings :: Map XmlName Count
76 } deriving (Eq,Ord,Show)
77 instance Default XmlPos where
78 def = XmlPos mempty mempty
85 deriving (Eq, Ord, Show)
88 newtype Nat1 = Nat1 Int
89 deriving (Eq, Ord, Show)
92 newtype Ident = Ident { unIdent :: Text }
93 deriving (Eq,Show,Default,IsString)
94 instance Default Text where
98 newtype URL = URL Text
99 deriving (Eq,Show,Default)
102 newtype Path = Path Text
103 deriving (Eq,Show,Default)
107 = MayText { unMayText :: Text }
108 deriving (Eq,Show,Default)
109 instance Semigroup MayText where
114 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
115 whenMayText (MayText "") _f = pure ()
116 whenMayText t f = f t