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.Map.Strict as Map
  24 import qualified Data.Text.Lazy as TL
  25
  26 import Language.TCT.Cell
  27 import Language.TCT.Debug
  28
  29 -- * Type 'XML'
  30 type XML  = Tree (Cell XmlNode)
  31 type XMLs = Seq XML
  32
  33 -- ** Type 'XmlName'
  34 data XmlName
  35  =   XmlName
  36  {   xmlNamePrefix :: TL.Text
  37  ,   xmlNameSpace  :: TL.Text
  38  ,   xmlNameLocal  :: TL.Text
  39  }
  40 instance Show XmlName where
  41         showsPrec _p XmlName{xmlNameSpace="", ..} =
  42                 showString (TL.unpack xmlNameLocal)
  43         showsPrec _p XmlName{..} =
  44                 if TL.null xmlNameSpace
  45                 then showString (TL.unpack xmlNameLocal)
  46                 else
  47                         showChar '{' .
  48                         showString (TL.unpack xmlNameSpace) .
  49                         showChar '}' .
  50                         showString (TL.unpack xmlNameLocal)
  51 instance Eq XmlName where
  52         XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
  53 instance Ord XmlName where
  54         XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
  55 instance IsString XmlName where
  56         fromString "" = XmlName "" "" ""
  57         fromString full@('{':rest) =
  58                 case List.break (== '}') rest of
  59                  (_, "")     -> error ("Invalid Clark notation: " <> show full)
  60                  (ns, local) -> XmlName "" (TL.pack ns) (TL.pack $ List.drop 1 local)
  61         fromString local = XmlName "" "" (TL.pack local)
  62 instance Pretty XmlName
  63
  64 xmlLocalName :: TL.Text -> XmlName
  65 xmlLocalName = XmlName "" ""
  66
  67 -- ** Type 'XmlNode'
  68 data XmlNode
  69  =   XmlElem    XmlName
  70  |   XmlAttr    XmlName TL.Text
  71  |   XmlComment TL.Text
  72  |   XmlText    TL.Text
  73  deriving (Eq,Ord,Show)
  74 instance Pretty XmlNode
  75
  76 -- ** Type 'XmlAttrs'
  77 type XmlAttrs = Map XmlName (Cell TL.Text)
  78
  79 -- * Type 'Rank'
  80 -- | nth child
  81 type Rank = Int
  82
  83 -- * Type 'Nat'
  84 newtype Nat = Nat { unNat :: Int }
  85  deriving (Eq, Ord, Show)
  86 instance Default Nat where
  87         def = Nat 0
  88
  89 succNat :: Nat -> Nat
  90 succNat (Nat n) = Nat $ succ n
  91
  92 predNat :: Nat -> Maybe Nat
  93 predNat (Nat n) | n <= 0    = Nothing
  94                 | otherwise = Just $ Nat $ pred n
  95
  96 -- * Type 'Nat1'
  97 newtype Nat1 = Nat1 { unNat1 :: Int }
  98  deriving (Eq, Ord, Show)
  99 instance Default Nat1 where
 100         def = Nat1 1
 101
 102 succNat1 :: Nat1 -> Nat1
 103 succNat1 (Nat1 n) = Nat1 $ succ n
 104 predNat1 :: Nat1 -> Maybe Nat1
 105 predNat1 (Nat1 n) | n <= 1    = Nothing
 106                   | otherwise = Just $ Nat1 $ pred n
 107
 108 -- * Type 'Ident'
 109 newtype Ident = Ident { unIdent :: Text }
 110  deriving (Eq,Ord,Show,Default,IsString)
 111 instance Default Text where
 112         def = ""
 113
 114 -- * Type 'URL'
 115 newtype URL = URL { unURL :: Text }
 116  deriving (Eq,Ord,Show,Default)
 117 instance Semigroup URL where
 118         _x <> y = y
 119
 120 -- * Type 'Path'
 121 newtype Path = Path Text
 122  deriving (Eq,Show,Default)
 123
 124 -- * Type 'MayText'
 125 newtype MayText
 126  =      MayText { unMayText :: Text }
 127  deriving (Eq,Show,Default)
 128 instance Semigroup MayText where
 129         MayText "" <> y = y
 130         x <> MayText "" = x
 131         _x <> y         = y
 132
 133 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 134 whenMayText (MayText "") _f = pure ()
 135 whenMayText t f = f t