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 (($), (.), on)
  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.Sequence as Seq
  26 import qualified Data.Text.Lazy as TL
  27
  28 import Hdoc.TCT.Cell
  29 import Hdoc.TCT.Debug
  30 import Hdoc.Utils ()
  31
  32 -- * Type 'XML'
  33 type XML  = Tree (Cell XmlNode)
  34 type XMLs = Seq XML
  35
  36 -- ** Type 'XmlName'
  37 data XmlName
  38  =   XmlName
  39  {   xmlNamePrefix :: TL.Text
  40  ,   xmlNameSpace  :: TL.Text
  41  ,   xmlNameLocal  :: TL.Text
  42  }
  43 instance Show XmlName where
  44         showsPrec _p XmlName{xmlNameSpace="", ..} =
  45                 showString (TL.unpack xmlNameLocal)
  46         showsPrec _p XmlName{..} =
  47                 if TL.null xmlNameSpace
  48                 then showString (TL.unpack xmlNameLocal)
  49                 else
  50                         showChar '{' .
  51                         showString (TL.unpack xmlNameSpace) .
  52                         showChar '}' .
  53                         showString (TL.unpack xmlNameLocal)
  54 instance Eq XmlName where
  55         XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
  56 instance Ord XmlName where
  57         XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
  58 instance IsString XmlName where
  59         fromString "" = XmlName "" "" ""
  60         fromString full@('{':rest) =
  61                 case List.break (== '}') rest of
  62                  (_, "")     -> error ("Invalid Clark notation: " <> show full)
  63                  (ns, local) -> XmlName "" (TL.pack ns) (TL.pack $ List.drop 1 local)
  64         fromString local = XmlName "" "" (TL.pack local)
  65 instance Pretty XmlName
  66 instance Hashable XmlName where
  67         hashWithSalt s XmlName{..} =
  68                 s`hashWithSalt`xmlNamePrefix
  69                  `hashWithSalt`xmlNameSpace
  70                  `hashWithSalt`xmlNameLocal
  71
  72 xmlLocalName :: TL.Text -> XmlName
  73 xmlLocalName = XmlName "" ""
  74
  75 -- ** Type 'XmlNode'
  76 data XmlNode
  77  =   XmlElem    XmlName
  78  |   XmlAttr    XmlName TL.Text
  79  |   XmlText    TL.Text
  80  |   XmlComment TL.Text
  81  deriving (Eq,Ord,Show)
  82 instance Pretty XmlNode
  83
  84 -- ** Type 'XmlAttrs'
  85 type XmlAttrs = Map XmlName (Cell TL.Text) -- TODO: HashMap
  86
  87 -- * Type 'Rank'
  88 -- | nth child
  89 type Rank = Int
  90
  91 -- * Type 'XmlPos'
  92 data XmlPos = XmlPos
  93  { xmlPos_Ancestors                :: XmlPosPath
  94  , xmlPos_AncestorsWithFigureNames :: XmlPosPath
  95  , xmlPos_PrecedingSiblings        :: Map XmlName Rank -- TODO: HashMap
  96  } deriving (Eq,Show)
  97 instance Ord XmlPos where
  98         compare = compare`on`xmlPos_Ancestors
  99 -- | Return only the hash on 'xmlPos_Ancestors',
 100 -- which is unique because 'XmlPosPath'
 101 -- includes the 'Rank' of each 'XmlNode'.
 102 instance Hashable XmlPos where
 103         hashWithSalt s XmlPos{..} =
 104                 s`hashWithSalt`xmlPos_Ancestors
 105 instance Default XmlPos where
 106         def = XmlPos mempty mempty mempty
 107
 108 -- ** Type 'XmlPosPath'
 109 type XmlPosPath = Seq (XmlName,Rank)
 110
 111 -- | Drop self.
 112 dropSelfPosPath :: XmlPosPath -> Maybe XmlPosPath
 113 dropSelfPosPath p =
 114         case Seq.viewr p of
 115          Seq.EmptyR -> Nothing
 116          ls Seq.:> _ -> Just ls
 117
 118 -- * Type 'Nat'
 119 newtype Nat = Nat { unNat :: Int }
 120  deriving (Eq,Ord,Hashable)
 121 instance Show Nat where
 122         showsPrec p = showsPrec p . unNat
 123 instance Default Nat where
 124         def = Nat 0
 125
 126 succNat :: Nat -> Nat
 127 succNat (Nat n) = Nat $ succ n
 128
 129 predNat :: Nat -> Maybe Nat
 130 predNat (Nat n) | n <= 0    = Nothing
 131                 | otherwise = Just $ Nat $ pred n
 132
 133 -- * Type 'Nat1'
 134 newtype Nat1 = Nat1 { unNat1 :: Int }
 135  deriving (Eq,Ord,Hashable)
 136 instance Show Nat1 where
 137         showsPrec p = showsPrec p . unNat1
 138 instance Default Nat1 where
 139         def = Nat1 1
 140
 141 succNat1 :: Nat1 -> Nat1
 142 succNat1 (Nat1 n) = Nat1 $ succ n
 143 predNat1 :: Nat1 -> Maybe Nat1
 144 predNat1 (Nat1 n) | n <= 1    = Nothing
 145                   | otherwise = Just $ Nat1 $ pred n
 146
 147 -- * Type 'Ident'
 148 newtype Ident = Ident { unIdent :: TL.Text }
 149  deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
 150
 151 -- * Type 'URL'
 152 newtype URL = URL { unURL :: TL.Text }
 153  deriving (Eq,Ord,Default,Hashable)
 154 instance Show URL where
 155         showsPrec p = showsPrec p . unURL
 156 instance Semigroup URL where
 157         _x <> y = y
 158
 159 -- * Type 'Path'
 160 newtype Path = Path TL.Text
 161  deriving (Eq,Show,Default)
 162
 163 -- * Type 'MayText'
 164 newtype MayText
 165  =      MayText { unMayText :: TL.Text }
 166  deriving (Eq,Ord,Default)
 167 instance Show MayText where
 168         showsPrec p = showsPrec p . unMayText
 169 instance Semigroup MayText where
 170         MayText "" <> y = y
 171         x <> MayText "" = x
 172         _x <> y         = y
 173
 174 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
 175 whenMayText (MayText "") _f = pure ()
 176 whenMayText t f = f t
 177
 178 instance Default Text where
 179         def = ""
 180 instance Default TL.Text where
 181         def = ""