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.Maybe (Maybe(..))
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, pred, succ)
21 import Text.Show (Show(..), showsPrec, showChar, showString)
22 import qualified Data.List as List
23 import qualified Data.Text.Lazy as TL
25 import Language.TCT.Cell
26 import Language.TCT.Debug
29 type XML = Tree (Cell XmlNode)
35 { xmlNamePrefix :: TL.Text
36 , xmlNameSpace :: TL.Text
37 , xmlNameLocal :: TL.Text
39 instance Show XmlName where
40 showsPrec _p XmlName{xmlNameSpace="", ..} =
41 showString (TL.unpack xmlNameLocal)
42 showsPrec _p XmlName{..} =
43 if TL.null xmlNameSpace
44 then showString (TL.unpack xmlNameLocal)
47 showString (TL.unpack xmlNameSpace) .
49 showString (TL.unpack xmlNameLocal)
50 instance Eq XmlName where
51 XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
52 instance Ord XmlName where
53 XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
54 instance IsString XmlName where
55 fromString "" = XmlName "" "" ""
56 fromString full@('{':rest) =
57 case List.break (== '}') rest of
58 (_, "") -> error ("Invalid Clark notation: " <> show full)
59 (ns, local) -> XmlName "" (TL.pack ns) (TL.pack $ List.drop 1 local)
60 fromString local = XmlName "" "" (TL.pack local)
61 instance Pretty XmlName
63 xmlLocalName :: TL.Text -> XmlName
64 xmlLocalName = XmlName "" ""
69 | XmlAttr XmlName TL.Text
72 deriving (Eq,Ord,Show)
73 instance Pretty XmlNode
76 type XmlAttrs = Map XmlName (Cell TL.Text)
83 newtype Nat = Nat { unNat :: Int }
84 deriving (Eq, Ord, Show)
85 instance Default Nat where
89 succNat (Nat n) = Nat $ succ n
91 predNat :: Nat -> Maybe Nat
92 predNat (Nat n) | n <= 0 = Nothing
93 | otherwise = Just $ Nat $ pred n
96 newtype Nat1 = Nat1 { unNat1 :: Int }
97 deriving (Eq, Ord, Show)
98 instance Default Nat1 where
101 succNat1 :: Nat1 -> Nat1
102 succNat1 (Nat1 n) = Nat1 $ succ n
103 predNat1 :: Nat1 -> Maybe Nat1
104 predNat1 (Nat1 n) | n <= 1 = Nothing
105 | otherwise = Just $ Nat1 $ pred n
108 newtype Ident = Ident { unIdent :: Text }
109 deriving (Eq,Ord,Show,Default,IsString)
110 instance Default Text where
114 newtype URL = URL { unURL :: Text }
115 deriving (Eq,Ord,Show,Default)
116 instance Semigroup URL where
120 newtype Path = Path Text
121 deriving (Eq,Show,Default)
125 = MayText { unMayText :: Text }
126 deriving (Eq,Show,Default)
127 instance Semigroup MayText where
132 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
133 whenMayText (MayText "") _f = pure ()
134 whenMayText t f = f t