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)
  22 import Text.Show (Show(..), showsPrec, showChar, showString)
  23 import qualified Data.List as List
  24 import qualified Data.Text as Text
  25
  26 import Language.TCT.Cell
  27
  28 -- * Type 'XML'
  29 type XML  = Tree (Cell XmlName) (Cell XmlLeaf)
  30 type XMLs = Seq XML
  31
  32 -- ** Type 'XmlName'
  33 data XmlName
  34  =   XmlName
  35  {   xmlNamePrefix :: Text
  36  ,   xmlNameSpace  :: Text
  37  ,   xmlNameLocal  :: Text
  38  }
  39 instance Show XmlName where
  40         showsPrec _p XmlName{xmlNameSpace="", ..} =
  41                 showString (Text.unpack xmlNameLocal)
  42         showsPrec _p XmlName{..} =
  43                 if Text.null xmlNameSpace
  44                 then showString (Text.unpack xmlNameLocal)
  45                 else
  46                         showChar '{' .
  47                         showString (Text.unpack xmlNameSpace) .
  48                         showChar '}' .
  49                         showString (Text.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 "" (Text.pack ns) (Text.pack $ List.drop 1 local)
  60         fromString local = XmlName "" "" (Text.pack local)
  61
  62 xmlLocalName :: Text -> XmlName
  63 xmlLocalName = XmlName "" ""
  64
  65 -- ** Type 'XmlLeaf'
  66 data XmlLeaf
  67  =   XmlAttr    XmlName Text
  68  |   XmlComment Text
  69  |   XmlText    Text
  70  deriving (Eq,Ord,Show)
  71
  72 -- * Type 'Rank'
  73 type Rank = Int
  74
  75 -- * Type 'Nat'
  76 newtype Nat = Nat { unNat :: Int }
  77  deriving (Eq, Ord, Show)
  78
  79 predNat :: Nat -> Maybe Nat
  80 predNat (Nat n) | n <= 0    = Nothing
  81                 | otherwise = Just $ Nat $ pred n
  82
  83 -- * Type 'Nat1'
  84 newtype Nat1 = Nat1 { unNat1 :: Int }
  85  deriving (Eq, Ord, Show)
  86
  87 predNat1 :: Nat1 -> Maybe Nat1
  88 predNat1 (Nat1 n) | n <= 1    = Nothing
  89                   | otherwise = Just $ Nat1 $ pred n
  90
  91 -- * Type 'Ident'
  92 newtype Ident = Ident { unIdent :: Text }
  93  deriving (Eq,Show,Default,IsString)
  94 instance Default Text where
  95         def = ""
  96
  97 -- * Type 'URL'
  98 newtype URL = URL Text
  99  deriving (Eq,Show,Default)
 100
 101 -- * Type 'Path'
 102 newtype Path = Path Text
 103  deriving (Eq,Show,Default)
 104
 105 -- * Type 'MayText'
 106 newtype MayText
 107  =      MayText { unMayText :: Text }
 108  deriving (Eq,Show,Default)
 109 instance Semigroup MayText where
 110         MayText "" <> y = y
 111         x <> MayText "" = x
 112         _x <> y          = y
 113
 114 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 115 whenMayText (MayText "") _f = pure ()
 116 whenMayText t f = f t