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.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)
  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 'XmlPos'
  71 data XmlPos
  72  =   XmlPos
  73  {   xmlPosAncestors          :: [(XmlName,Count)]
  74  ,   xmlPosPrecedingsSiblings :: Map XmlName Count
  75  } deriving (Eq,Show)
  76 type Count = Int
  77
  78 -- * Type 'Nat'
  79 newtype Nat = Nat Int
  80  deriving (Eq, Ord, Show)
  81
  82 -- * Type 'Nat1'
  83 newtype Nat1 = Nat1 Int
  84  deriving (Eq, Ord, Show)
  85
  86 -- * Type 'Ident'
  87 newtype Ident = Ident { unIdent :: Text }
  88  deriving (Eq,Show,Default,IsString)
  89 instance Default Text where
  90         def = ""
  91
  92 -- * Type 'URL'
  93 newtype URL = URL Text
  94  deriving (Eq,Show,Default)
  95
  96 -- * Type 'Path'
  97 newtype Path = Path Text
  98  deriving (Eq,Show,Default)
  99
 100 -- * Type 'MayText'
 101 newtype MayText
 102  =      MayText { unMayText :: Text }
 103  deriving (Eq,Show,Default)
 104 instance Semigroup MayText where
 105         MayText "" <> y = y
 106         x <> MayText "" = x
 107         _x <> y          = y
 108
 109 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 110 whenMayText (MayText "") _f = pure ()
 111 whenMayText t f = f t