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