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 'XmlPos'
  73 data XmlPos
  74  =   XmlPos
  75  {   xmlPosAncestors          :: [(XmlName,Rank)]
  76  ,   xmlPosPrecedingsSiblings :: Map XmlName Rank
  77  } deriving (Eq,Ord,Show)
  78 instance Default XmlPos where
  79         def = XmlPos mempty mempty
  80
  81 -- * Type 'Rank'
  82 type Rank = Int
  83
  84 -- * Type 'Nat'
  85 newtype Nat = Nat { unNat :: Int }
  86  deriving (Eq, Ord, Show)
  87
  88 predNat :: Nat -> Maybe Nat
  89 predNat (Nat n) | n <= 0    = Nothing
  90                 | otherwise = Just $ Nat $ pred n
  91
  92 -- * Type 'Nat1'
  93 newtype Nat1 = Nat1 { unNat1 :: Int }
  94  deriving (Eq, Ord, Show)
  95
  96 predNat1 :: Nat1 -> Maybe Nat1
  97 predNat1 (Nat1 n) | n <= 1    = Nothing
  98                   | otherwise = Just $ Nat1 $ pred n
  99
 100 -- * Type 'Ident'
 101 newtype Ident = Ident { unIdent :: Text }
 102  deriving (Eq,Show,Default,IsString)
 103 instance Default Text where
 104         def = ""
 105
 106 -- * Type 'URL'
 107 newtype URL = URL Text
 108  deriving (Eq,Show,Default)
 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