Language/XML.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Language.XML where
   6
   7 import Control.Applicative (Applicative(..))
   8 import Data.Bool
   9 import Data.Default.Class (Default(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Function (($), (.))
  12 import Data.Int (Int)
  13 import Data.Map.Strict (Map)
  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)
  21 import Text.Show (Show(..), showsPrec, showChar, showString)
  22 import qualified Data.List as List
  23 import qualified Data.Text as Text
  24
  25 import Language.TCT.Cell
  26
  27 -- * Type 'XML'
  28 type XML  = Tree (Cell XmlName) (Cell XmlLeaf)
  29 type XMLs = Seq XML
  30
  31 -- ** Type 'XmlName'
  32 data XmlName
  33  =   XmlName
  34  {   xmlNamePrefix :: Text
  35  ,   xmlNameSpace  :: Text
  36  ,   xmlNameLocal  :: Text
  37  }
  38 instance Show XmlName where
  39         showsPrec _p XmlName{xmlNameSpace="", ..} =
  40                 showString (Text.unpack xmlNameLocal)
  41         showsPrec _p XmlName{..} =
  42                 if Text.null xmlNameSpace
  43                 then showString (Text.unpack xmlNameLocal)
  44                 else
  45                         showChar '{' .
  46                         showString (Text.unpack xmlNameSpace) .
  47                         showChar '}' .
  48                         showString (Text.unpack xmlNameLocal)
  49 instance Eq XmlName where
  50         XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
  51 instance Ord XmlName where
  52         XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
  53 instance IsString XmlName where
  54         fromString "" = XmlName "" "" ""
  55         fromString full@('{':rest) =
  56                 case List.break (== '}') rest of
  57                  (_, "")     -> error ("Invalid Clark notation: " <> show full)
  58                  (ns, local) -> XmlName "" (Text.pack ns) (Text.pack $ List.drop 1 local)
  59         fromString local = XmlName "" "" (Text.pack local)
  60
  61 xmlLocalName :: Text -> XmlName
  62 xmlLocalName = XmlName "" ""
  63
  64 -- ** Type 'XmlLeaf'
  65 data XmlLeaf
  66  =   XmlAttr    XmlName Text
  67  |   XmlComment Text
  68  |   XmlText    Text
  69  deriving (Eq,Ord,Show)
  70
  71 -- ** Type 'XmlPos'
  72 data XmlPos
  73  =   XmlPos
  74  {   xmlPosAncestors          :: [(XmlName,Count)]
  75  ,   xmlPosPrecedingsSiblings :: Map XmlName Count
  76  } deriving (Eq,Show)
  77 type Count = Int
  78
  79 -- * Type 'Nat'
  80 newtype Nat = Nat Int
  81  deriving (Eq, Ord, Show)
  82
  83 -- * Type 'Nat1'
  84 newtype Nat1 = Nat1 Int
  85  deriving (Eq, Ord, Show)
  86
  87 -- * Type 'Ident'
  88 newtype Ident = Ident { unIdent :: Text }
  89  deriving (Eq,Show,Default,IsString)
  90 instance Default Text where
  91         def = ""
  92
  93 -- * Type 'URL'
  94 newtype URL = URL Text
  95  deriving (Eq,Show,Default)
  96
  97 -- * Type 'Path'
  98 newtype Path = Path Text
  99  deriving (Eq,Show,Default)
 100
 101 -- * Type 'MayText'
 102 newtype MayText
 103  =      MayText { unMayText :: Text }
 104  deriving (Eq,Show,Default)
 105 instance Semigroup MayText where
 106         MayText "" <> y = y
 107         x <> MayText "" = x
 108         _x <> y          = y
 109
 110 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 111 whenMayText (MayText "") _f = pure ()
 112 whenMayText t f = f t