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  |   XmlComment TL.Text
  71  |   XmlText    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, Show)
  85 instance Default Nat where
  86         def = Nat 0
  87
  88 succNat :: Nat -> Nat
  89 succNat (Nat n) = Nat $ succ n
  90
  91 predNat :: Nat -> Maybe Nat
  92 predNat (Nat n) | n <= 0    = Nothing
  93                 | otherwise = Just $ Nat $ pred n
  94
  95 -- * Type 'Nat1'
  96 newtype Nat1 = Nat1 { unNat1 :: Int }
  97  deriving (Eq, Ord, Show)
  98 instance Default Nat1 where
  99         def = Nat1 1
 100
 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
 106
 107 -- * Type 'Ident'
 108 newtype Ident = Ident { unIdent :: TL.Text }
 109  deriving (Eq,Ord,Show,Default,IsString)
 110
 111 -- * Type 'URL'
 112 newtype URL = URL { unURL :: TL.Text }
 113  deriving (Eq,Ord,Show,Default)
 114 instance Semigroup URL where
 115         _x <> y = y
 116
 117 -- * Type 'Path'
 118 newtype Path = Path TL.Text
 119  deriving (Eq,Show,Default)
 120
 121 -- * Type 'MayText'
 122 newtype MayText
 123  =      MayText { unMayText :: TL.Text }
 124  deriving (Eq,Show,Default)
 125 instance Semigroup MayText where
 126         MayText "" <> y = y
 127         x <> MayText "" = x
 128         _x <> y         = y
 129
 130 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 131 whenMayText (MayText "") _f = pure ()
 132 whenMayText t f = f t
 133
 134 instance Default Text where
 135         def = ""
 136 instance Default TL.Text where
 137         def = ""