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