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