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