Language/Symantic/XML/Document.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE PatternSynonyms #-}
   5 {-# LANGUAGE ViewPatterns #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Language.Symantic.XML.Document
   8  ( module Language.Symantic.XML.Document
   9  , TS.Tree(..)
  10  , TS.Trees
  11  ) where
  12
  13 import Data.Bool
  14 import Data.Eq (Eq(..))
  15 import Data.Foldable (Foldable(..), all)
  16 import Data.Function (($), (.), id)
  17 import Data.Hashable (Hashable(..))
  18 import Data.Maybe (Maybe(..))
  19 import Data.Ord (Ord(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.String (String, IsString(..))
  22 import GHC.Generics (Generic)
  23 import Prelude (error)
  24 import Text.Show (Show(..), showsPrec, showChar, showString)
  25 import qualified Data.Char.Properties.XMLCharProps as XC
  26 import qualified Data.List as List
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Data.TreeSeq.Strict as TS
  29 import qualified Data.Sequence as Seq
  30
  31 pattern Tree0 :: a -> TS.Tree a
  32 pattern Tree0 a <- TS.Tree a (null -> True)
  33         where Tree0 a = TS.Tree a Seq.empty
  34
  35 -- ** Type 'Node'
  36 data Node
  37  =   NodeElem    !QName          -- ^ Node with some 'NodeAttr' and then other 'Node's as children.
  38  |   NodeAttr    !QName          -- ^ Node with a 'NodeText' child.
  39  |   NodePI      !PName !TL.Text -- ^ Leaf (except for @<?xml?>@ which has 'NodeAttr's.
  40  |   NodeText    !Text           -- ^ Leaf.
  41  |   NodeComment !TL.Text        -- ^ Leaf.
  42  |   NodeCDATA   !TL.Text        -- ^ Leaf.
  43  deriving (Eq,Ord,Show)
  44
  45 -- ** Type 'Text'
  46 type Text = TL.Text
  47
  48 -- ** Type 'Name'
  49 newtype Name = Name { unName :: TL.Text }
  50  deriving (Eq,Ord,Hashable)
  51 instance Show Name where
  52         showsPrec _p = showString . TL.unpack . unName
  53 instance IsString Name where
  54         fromString s
  55          | c:cs <- s
  56          , XC.isXmlNameStartChar c
  57          && all XC.isXmlNameChar cs
  58          = Name (TL.pack s)
  59          | otherwise = error "Invalid XML Name"
  60
  61 -- ** Type 'NCName'
  62 -- | Non-colonized name.
  63 newtype NCName = NCName { unNCName :: TL.Text }
  64  deriving (Eq,Ord,Hashable)
  65 instance Show NCName where
  66         showsPrec _p = showString . TL.unpack . unNCName
  67 instance IsString NCName where
  68         fromString s
  69          | c:cs <- s
  70          , XC.isXmlNCNameStartChar c
  71          && all XC.isXmlNCNameChar cs
  72          = NCName (TL.pack s)
  73          | otherwise = error "Invalid XML NCName"
  74
  75 -- ** Type 'PName'
  76 -- | Prefixed name.
  77 data PName = PName
  78  { pNameSpace :: !(Maybe NCName) -- ^ eg. Just "xml"
  79  , pNameLocal :: !NCName         -- ^ eg. "stylesheet"
  80  } deriving (Eq,Ord,Generic)
  81 instance Show PName where
  82         showsPrec p PName{pNameSpace=Nothing, ..} =
  83                 showsPrec p pNameLocal
  84         showsPrec _p PName{pNameSpace=Just p, ..} =
  85                 showsPrec 10 p .
  86                 showChar ':' .
  87                 showsPrec 10 pNameLocal
  88 instance IsString PName where
  89         fromString "" = PName Nothing "" -- NOTE: NCName's fromString will raise an error.
  90         fromString s =
  91                 case List.break (== ':') s of
  92                  (_, "")    -> PName Nothing $ fromString s
  93                  (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local)
  94 instance Hashable PName
  95
  96 pName :: NCName -> PName
  97 pName = PName Nothing
  98 {-# INLINE pName #-}
  99
 100 -- ** Type 'QName'
 101 -- | Qualified name.
 102 data QName = QName
 103  { qNameSpace :: !Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
 104  , qNameLocal :: !NCName    -- ^ eg. "stylesheet"
 105  } deriving (Eq,Ord,Generic)
 106 instance Show QName where
 107         showsPrec _p QName{..} =
 108                 (if TL.null $ unNamespace qNameSpace then id
 109                 else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}'
 110                 ) . showsPrec 10 qNameLocal
 111 instance IsString QName where
 112         fromString "" = QName "" "" -- NOTE: NCName's fromString will raise an error.
 113         fromString full@('{':rest) =
 114                 case List.break (== '}') rest of
 115                  (_, "")     -> error ("Invalid XML Clark notation: " <> show full)
 116                  (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local
 117         fromString local = QName "" $ fromString local
 118 instance Hashable QName
 119
 120 qName :: NCName -> QName
 121 qName = QName ""
 122 {-# INLINE qName #-}
 123
 124 -- *** Type 'Namespace'
 125 newtype Namespace = Namespace { unNamespace :: TL.Text }
 126  deriving (Eq,Ord,Show,Hashable)
 127 instance IsString Namespace where
 128         fromString s =
 129                 if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s
 130                 then Namespace (fromString s)
 131                 else error $ "Invalid XML Namespace: " <> show s
 132
 133 xmlns_xml, xmlns_xmlns :: Namespace
 134 xmlns_xml   = Namespace "http://www.w3.org/XML/1998/namespace"
 135 xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/"