Hdoc/XML.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hdoc.XML where
   5
   6 import Data.Bool
   7 import Data.Default.Class (Default(..))
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.), on)
  10 import Data.Hashable (Hashable(..))
  11 import Data.Map.Strict (Map)
  12 import Data.Maybe (Maybe(..))
  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.TreeSeq.Strict (Tree)
  19 import Prelude (error)
  20 import Text.Show (Show(..), showsPrec, showChar, showString)
  21 import qualified Data.List as List
  22 import qualified Data.Sequence as Seq
  23 import qualified Data.Text.Lazy as TL
  24
  25 import qualified Hdoc.TCT.Cell as TCT
  26 import Hdoc.TCT.Debug
  27 import Hdoc.Utils (Nat1)
  28
  29 -- * Type 'XML'
  30 type XML  = Tree (TCT.Cell Node)
  31 type XMLs = Seq XML
  32
  33 -- ** Type 'Name'
  34 data Name = Name
  35  { namePrefix :: TL.Text -- ^ eg. "xsl"
  36  , nameSpace  :: TL.Text -- ^ eg. "http://www.w3.org/1999/XSL/Transform"
  37  , nameLocal  :: TL.Text -- ^ eg. "stylesheet"
  38  }
  39 instance Show Name where
  40         showsPrec _p Name{nameSpace="", ..} =
  41                 showString (TL.unpack nameLocal)
  42         showsPrec _p Name{..} =
  43                 if TL.null nameSpace
  44                 then showString (TL.unpack nameLocal)
  45                 else
  46                         showChar '{' .
  47                         showString (TL.unpack nameSpace) .
  48                         showChar '}' .
  49                         showString (TL.unpack nameLocal)
  50 instance Eq Name where
  51         Name _ sx lx == Name _ sy ly = sx == sy && lx == ly
  52 instance Ord Name where
  53         Name _ sx lx `compare` Name _ sy ly = compare sx sy <> compare lx ly
  54 instance IsString Name where
  55         fromString "" = Name "" "" ""
  56         fromString full@('{':rest) =
  57                 case List.break (== '}') rest of
  58                  (_, "")     -> error ("Invalid Clark notation: " <> show full)
  59                  (ns, local) -> Name "" (TL.pack ns) (TL.pack $ List.drop 1 local)
  60         fromString local = Name "" "" (TL.pack local)
  61 instance Pretty Name
  62 instance Hashable Name where
  63         hashWithSalt s Name{..} =
  64                 s`hashWithSalt`namePrefix
  65                  `hashWithSalt`nameSpace
  66                  `hashWithSalt`nameLocal
  67
  68 localName :: TL.Text -> Name
  69 localName = Name "" ""
  70
  71 -- ** Type 'Node'
  72 data Node
  73  =   NodeElem    Name
  74  |   NodeAttr    Name TL.Text
  75  |   NodeText    TL.Text
  76  |   NodeComment TL.Text
  77  deriving (Eq,Ord,Show)
  78 instance Pretty Node
  79
  80 -- ** Type 'Attrs'
  81 type Attrs = Map Name (TCT.Cell TL.Text)
  82
  83 -- * Type 'Pos'
  84 data Pos = Pos
  85  { pos_ancestors                :: Ancestors
  86  , pos_ancestorsWithFigureNames :: Ancestors
  87  , pos_precedingSiblings        :: Map Name Rank
  88  } deriving (Eq,Show)
  89 instance Ord Pos where
  90         compare = compare`on`pos_ancestors
  91 -- | Return only the hash on 'pos_ancestors',
  92 -- which is unique because 'Ancestors'
  93 -- includes the 'Rank' of each 'Node'.
  94 instance Hashable Pos where
  95         hashWithSalt s Pos{..} =
  96                 s`hashWithSalt`pos_ancestors
  97 instance Default Pos where
  98         def = Pos mempty mempty mempty
  99
 100 -- ** Type 'Rank'
 101 -- | Nth child.
 102 type Rank = Nat1
 103
 104 -- ** Type 'Ancestors'
 105 type Ancestors = Seq (Name, Rank)
 106
 107 ancestors :: Ancestors -> Maybe Ancestors
 108 ancestors p =
 109         case Seq.viewr p of
 110          Seq.EmptyR -> Nothing
 111          ls Seq.:> _ -> Just ls
 112
 113 -- * Type 'Ident'
 114 newtype Ident = Ident { unIdent :: TL.Text }
 115  deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
 116
 117 -- * Type 'URL'
 118 newtype URL = URL { unURL :: TL.Text }
 119  deriving (Eq,Ord,Default,Hashable)
 120 instance Show URL where
 121         showsPrec p = showsPrec p . unURL
 122 instance Semigroup URL where
 123         _x <> y = y