Language/XML.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Language.XML where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Bool
   8 import Data.Default.Class (Default(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($), (.))
  11 import Data.Int (Int)
  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
  24
  25 import Language.TCT.Cell
  26 import Language.TCT.Debug
  27
  28 -- * Type 'XML'
  29 type XML  = Tree (Cell XmlNode)
  30 type XMLs = Seq XML
  31
  32 -- ** Type 'XmlName'
  33 data XmlName
  34  =   XmlName
  35  {   xmlNamePrefix :: TL.Text
  36  ,   xmlNameSpace  :: TL.Text
  37  ,   xmlNameLocal  :: TL.Text
  38  }
  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)
  45                 else
  46                         showChar '{' .
  47                         showString (TL.unpack xmlNameSpace) .
  48                         showChar '}' .
  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
  62
  63 xmlLocalName :: TL.Text -> XmlName
  64 xmlLocalName = XmlName "" ""
  65
  66 -- ** Type 'XmlNode'
  67 data XmlNode
  68  =   XmlElem    XmlName
  69  |   XmlAttr    XmlName TL.Text
  70  |   XmlText    TL.Text
  71  |   XmlComment TL.Text
  72  deriving (Eq,Ord,Show)
  73 instance Pretty XmlNode
  74
  75 -- ** Type 'XmlAttrs'
  76 type XmlAttrs = Map XmlName (Cell TL.Text)
  77
  78 -- * Type 'Rank'
  79 -- | nth child
  80 type Rank = Int
  81
  82 -- * Type 'Nat'
  83 newtype Nat = Nat { unNat :: Int }
  84  deriving (Eq, Ord)
  85 instance Show Nat where
  86         showsPrec p = showsPrec p . unNat
  87 instance Default Nat where
  88         def = Nat 0
  89
  90 succNat :: Nat -> Nat
  91 succNat (Nat n) = Nat $ succ n
  92
  93 predNat :: Nat -> Maybe Nat
  94 predNat (Nat n) | n <= 0    = Nothing
  95                 | otherwise = Just $ Nat $ pred n
  96
  97 -- * Type 'Nat1'
  98 newtype Nat1 = Nat1 { unNat1 :: Int }
  99  deriving (Eq, Ord)
 100 instance Show Nat1 where
 101         showsPrec p = showsPrec p . unNat1
 102 instance Default Nat1 where
 103         def = Nat1 1
 104
 105 succNat1 :: Nat1 -> Nat1
 106 succNat1 (Nat1 n) = Nat1 $ succ n
 107 predNat1 :: Nat1 -> Maybe Nat1
 108 predNat1 (Nat1 n) | n <= 1    = Nothing
 109                   | otherwise = Just $ Nat1 $ pred n
 110
 111 -- * Type 'Ident'
 112 newtype Ident = Ident { unIdent :: TL.Text }
 113  deriving (Eq,Ord,Show,Default,IsString)
 114
 115 -- * Type 'URL'
 116 newtype URL = URL { unURL :: TL.Text }
 117  deriving (Eq,Ord,Default)
 118 instance Show URL where
 119         showsPrec p = showsPrec p . unURL
 120 instance Semigroup URL where
 121         _x <> y = y
 122
 123 -- * Type 'Path'
 124 newtype Path = Path TL.Text
 125  deriving (Eq,Show,Default)
 126
 127 -- * Type 'MayText'
 128 newtype MayText
 129  =      MayText { unMayText :: TL.Text }
 130  deriving (Eq,Ord,Default)
 131 instance Show MayText where
 132         showsPrec p = showsPrec p . unMayText
 133 instance Semigroup MayText where
 134         MayText "" <> y = y
 135         x <> MayText "" = x
 136         _x <> y         = y
 137
 138 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 139 whenMayText (MayText "") _f = pure ()
 140 whenMayText t f = f t
 141
 142 instance Default Text where
 143         def = ""
 144 instance Default TL.Text where
 145         def = ""