1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 import Control.Applicative (Applicative(..))
8 import Data.Default.Class (Default(..))
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.))
12 import Data.Hashable (Hashable(..))
13 import Data.Map.Strict (Map)
14 import Data.Maybe (Maybe(..))
15 import Data.Monoid (Monoid(..))
16 import Data.Ord (Ord(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.Sequence (Seq)
19 import Data.String (IsString(..))
20 import Data.Text (Text)
21 import Data.TreeSeq.Strict (Tree)
22 import Prelude (error, pred, succ)
23 import Text.Show (Show(..), showsPrec, showChar, showString)
24 import qualified Data.List as List
25 import qualified Data.Text.Lazy as TL
31 type XML = Tree (Cell XmlNode)
37 { xmlNamePrefix :: TL.Text
38 , xmlNameSpace :: TL.Text
39 , xmlNameLocal :: TL.Text
41 instance Show XmlName where
42 showsPrec _p XmlName{xmlNameSpace="", ..} =
43 showString (TL.unpack xmlNameLocal)
44 showsPrec _p XmlName{..} =
45 if TL.null xmlNameSpace
46 then showString (TL.unpack xmlNameLocal)
49 showString (TL.unpack xmlNameSpace) .
51 showString (TL.unpack xmlNameLocal)
52 instance Eq XmlName where
53 XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
54 instance Ord XmlName where
55 XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
56 instance IsString XmlName where
57 fromString "" = XmlName "" "" ""
58 fromString full@('{':rest) =
59 case List.break (== '}') rest of
60 (_, "") -> error ("Invalid Clark notation: " <> show full)
61 (ns, local) -> XmlName "" (TL.pack ns) (TL.pack $ List.drop 1 local)
62 fromString local = XmlName "" "" (TL.pack local)
63 instance Pretty XmlName
64 instance Hashable XmlName where
65 hashWithSalt s XmlName{..} =
66 s`hashWithSalt`xmlNamePrefix
67 `hashWithSalt`xmlNameSpace
68 `hashWithSalt`xmlNameLocal
70 xmlLocalName :: TL.Text -> XmlName
71 xmlLocalName = XmlName "" ""
76 | XmlAttr XmlName TL.Text
79 deriving (Eq,Ord,Show)
80 instance Pretty XmlNode
83 type XmlAttrs = Map XmlName (Cell TL.Text) -- TODO: HashMap
90 newtype Nat = Nat { unNat :: Int }
91 deriving (Eq,Ord,Hashable)
92 instance Show Nat where
93 showsPrec p = showsPrec p . unNat
94 instance Default Nat where
98 succNat (Nat n) = Nat $ succ n
100 predNat :: Nat -> Maybe Nat
101 predNat (Nat n) | n <= 0 = Nothing
102 | otherwise = Just $ Nat $ pred n
105 newtype Nat1 = Nat1 { unNat1 :: Int }
106 deriving (Eq,Ord,Hashable)
107 instance Show Nat1 where
108 showsPrec p = showsPrec p . unNat1
109 instance Default Nat1 where
112 succNat1 :: Nat1 -> Nat1
113 succNat1 (Nat1 n) = Nat1 $ succ n
114 predNat1 :: Nat1 -> Maybe Nat1
115 predNat1 (Nat1 n) | n <= 1 = Nothing
116 | otherwise = Just $ Nat1 $ pred n
119 newtype Ident = Ident { unIdent :: TL.Text }
120 deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
123 newtype URL = URL { unURL :: TL.Text }
124 deriving (Eq,Ord,Default,Hashable)
125 instance Show URL where
126 showsPrec p = showsPrec p . unURL
127 instance Semigroup URL where
131 newtype Path = Path TL.Text
132 deriving (Eq,Show,Default)
136 = MayText { unMayText :: TL.Text }
137 deriving (Eq,Ord,Default)
138 instance Show MayText where
139 showsPrec p = showsPrec p . unMayText
140 instance Semigroup MayText where
145 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
146 whenMayText (MayText "") _f = pure ()
147 whenMayText t f = f t
149 instance Default Text where
151 instance Default TL.Text where