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.Monoid (Monoid(..))
  15 import Data.Ord (Ord(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.Sequence (Seq)
  18 import Data.String (IsString(..))
  19 import Data.Text (Text)
  20 import Data.TreeSeq.Strict (Tree)
  21 import Prelude (error, pred, succ)
  22 import Text.Show (Show(..), showsPrec, showChar, showString)
  23 import qualified Data.List as List
  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  |   XmlText    TL.Text
  72  |   XmlComment 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)
  86 instance Show Nat where
  87         showsPrec p = showsPrec p . unNat
  88 instance Default Nat where
  89         def = Nat 0
  90
  91 succNat :: Nat -> Nat
  92 succNat (Nat n) = Nat $ succ n
  93
  94 predNat :: Nat -> Maybe Nat
  95 predNat (Nat n) | n <= 0    = Nothing
  96                 | otherwise = Just $ Nat $ pred n
  97
  98 -- * Type 'Nat1'
  99 newtype Nat1 = Nat1 { unNat1 :: Int }
 100  deriving (Eq, Ord)
 101 instance Show Nat1 where
 102         showsPrec p = showsPrec p . unNat1
 103 instance Default Nat1 where
 104         def = Nat1 1
 105
 106 succNat1 :: Nat1 -> Nat1
 107 succNat1 (Nat1 n) = Nat1 $ succ n
 108 predNat1 :: Nat1 -> Maybe Nat1
 109 predNat1 (Nat1 n) | n <= 1    = Nothing
 110                   | otherwise = Just $ Nat1 $ pred n
 111
 112 -- * Type 'Ident'
 113 newtype Ident = Ident { unIdent :: TL.Text }
 114  deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid)
 115
 116 -- * Type 'URL'
 117 newtype URL = URL { unURL :: TL.Text }
 118  deriving (Eq,Ord,Default)
 119 instance Show URL where
 120         showsPrec p = showsPrec p . unURL
 121 instance Semigroup URL where
 122         _x <> y = y
 123
 124 -- * Type 'Path'
 125 newtype Path = Path TL.Text
 126  deriving (Eq,Show,Default)
 127
 128 -- * Type 'MayText'
 129 newtype MayText
 130  =      MayText { unMayText :: TL.Text }
 131  deriving (Eq,Ord,Default)
 132 instance Show MayText where
 133         showsPrec p = showsPrec p . unMayText
 134 instance Semigroup MayText where
 135         MayText "" <> y = y
 136         x <> MayText "" = x
 137         _x <> y         = y
 138
 139 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 140 whenMayText (MayText "") _f = pure ()
 141 whenMayText t f = f t
 142
 143 instance Default Text where
 144         def = ""
 145 instance Default TL.Text where
 146         def = ""