Hdoc/XML.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hdoc.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.Hashable (Hashable(..))
  13 import Data.Map.Strict (Map)
  14 import Data.Maybe (Maybe(..))
  15 import Data.Monoid (Monoid(..))
  16 import Data.Ord (Ord(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.Sequence (Seq)
  19 import Data.String (IsString(..))
  20 import Data.Text (Text)
  21 import Data.TreeSeq.Strict (Tree)
  22 import Prelude (error, pred, succ)
  23 import Text.Show (Show(..), showsPrec, showChar, showString)
  24 import qualified Data.List as List
  25 import qualified Data.Text.Lazy as TL
  26
  27 import Hdoc.TCT.Cell
  28 import Hdoc.TCT.Debug
  29
  30 -- * Type 'XML'
  31 type XML  = Tree (Cell XmlNode)
  32 type XMLs = Seq XML
  33
  34 -- ** Type 'XmlName'
  35 data XmlName
  36  =   XmlName
  37  {   xmlNamePrefix :: TL.Text
  38  ,   xmlNameSpace  :: TL.Text
  39  ,   xmlNameLocal  :: TL.Text
  40  }
  41 instance Show XmlName where
  42         showsPrec _p XmlName{xmlNameSpace="", ..} =
  43                 showString (TL.unpack xmlNameLocal)
  44         showsPrec _p XmlName{..} =
  45                 if TL.null xmlNameSpace
  46                 then showString (TL.unpack xmlNameLocal)
  47                 else
  48                         showChar '{' .
  49                         showString (TL.unpack xmlNameSpace) .
  50                         showChar '}' .
  51                         showString (TL.unpack xmlNameLocal)
  52 instance Eq XmlName where
  53         XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
  54 instance Ord XmlName where
  55         XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
  56 instance IsString XmlName where
  57         fromString "" = XmlName "" "" ""
  58         fromString full@('{':rest) =
  59                 case List.break (== '}') rest of
  60                  (_, "")     -> error ("Invalid Clark notation: " <> show full)
  61                  (ns, local) -> XmlName "" (TL.pack ns) (TL.pack $ List.drop 1 local)
  62         fromString local = XmlName "" "" (TL.pack local)
  63 instance Pretty XmlName
  64 instance Hashable XmlName where
  65         hashWithSalt s XmlName{..} =
  66                 s`hashWithSalt`xmlNamePrefix
  67                  `hashWithSalt`xmlNameSpace
  68                  `hashWithSalt`xmlNameLocal
  69
  70 xmlLocalName :: TL.Text -> XmlName
  71 xmlLocalName = XmlName "" ""
  72
  73 -- ** Type 'XmlNode'
  74 data XmlNode
  75  =   XmlElem    XmlName
  76  |   XmlAttr    XmlName TL.Text
  77  |   XmlText    TL.Text
  78  |   XmlComment TL.Text
  79  deriving (Eq,Ord,Show)
  80 instance Pretty XmlNode
  81
  82 -- ** Type 'XmlAttrs'
  83 type XmlAttrs = Map XmlName (Cell TL.Text) -- TODO: HashMap
  84
  85 -- * Type 'Rank'
  86 -- | nth child
  87 type Rank = Int
  88
  89 -- * Type 'Nat'
  90 newtype Nat = Nat { unNat :: Int }
  91  deriving (Eq,Ord,Hashable)
  92 instance Show Nat where
  93         showsPrec p = showsPrec p . unNat
  94 instance Default Nat where
  95         def = Nat 0
  96
  97 succNat :: Nat -> Nat
  98 succNat (Nat n) = Nat $ succ n
  99
 100 predNat :: Nat -> Maybe Nat
 101 predNat (Nat n) | n <= 0    = Nothing
 102                 | otherwise = Just $ Nat $ pred n
 103
 104 -- * Type 'Nat1'
 105 newtype Nat1 = Nat1 { unNat1 :: Int }
 106  deriving (Eq,Ord,Hashable)
 107 instance Show Nat1 where
 108         showsPrec p = showsPrec p . unNat1
 109 instance Default Nat1 where
 110         def = Nat1 1
 111
 112 succNat1 :: Nat1 -> Nat1
 113 succNat1 (Nat1 n) = Nat1 $ succ n
 114 predNat1 :: Nat1 -> Maybe Nat1
 115 predNat1 (Nat1 n) | n <= 1    = Nothing
 116                   | otherwise = Just $ Nat1 $ pred n
 117
 118 -- * Type 'Ident'
 119 newtype Ident = Ident { unIdent :: TL.Text }
 120  deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
 121
 122 -- * Type 'URL'
 123 newtype URL = URL { unURL :: TL.Text }
 124  deriving (Eq,Ord,Default,Hashable)
 125 instance Show URL where
 126         showsPrec p = showsPrec p . unURL
 127 instance Semigroup URL where
 128         _x <> y = y
 129
 130 -- * Type 'Path'
 131 newtype Path = Path TL.Text
 132  deriving (Eq,Show,Default)
 133
 134 -- * Type 'MayText'
 135 newtype MayText
 136  =      MayText { unMayText :: TL.Text }
 137  deriving (Eq,Ord,Default)
 138 instance Show MayText where
 139         showsPrec p = showsPrec p . unMayText
 140 instance Semigroup MayText where
 141         MayText "" <> y = y
 142         x <> MayText "" = x
 143         _x <> y         = y
 144
 145 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 146 whenMayText (MayText "") _f = pure ()
 147 whenMayText t f = f t
 148
 149 instance Default Text where
 150         def = ""
 151 instance Default TL.Text where
 152         def = ""