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  -- TODO: Map -> HashMap?
  83
  84 -- * Type 'Pos'
  85 data Pos = Pos
  86  { pos_ancestors                :: Ancestors
  87  , pos_ancestorsWithFigureNames :: Ancestors
  88  , pos_precedingSiblings        :: Map Name Rank
  89  } deriving (Eq,Show)
  90 instance Ord Pos where
  91         compare = compare`on`pos_ancestors
  92 -- | Return only the hash on 'pos_ancestors',
  93 -- which is unique because 'Ancestors'
  94 -- includes the 'Rank' of each 'Node'.
  95 instance Hashable Pos where
  96         hashWithSalt s Pos{..} =
  97                 s`hashWithSalt`pos_ancestors
  98 instance Default Pos where
  99         def = Pos mempty mempty mempty
 100
 101 -- ** Type 'Rank'
 102 -- | Nth child.
 103 type Rank = Nat1
 104
 105 -- ** Type 'Ancestors'
 106 type Ancestors = Seq (Name, Rank)
 107
 108 ancestors :: Ancestors -> Maybe Ancestors
 109 ancestors p =
 110         case Seq.viewr p of
 111          Seq.EmptyR -> Nothing
 112          ls Seq.:> _ -> Just ls
 113
 114 -- * Type 'Ident'
 115 newtype Ident = Ident { unIdent :: TL.Text }
 116  deriving (Eq,Ord,Show,Default,IsString,Semigroup,Monoid,Hashable)
 117
 118 -- * Type 'URL'
 119 newtype URL = URL { unURL :: TL.Text }
 120  deriving (Eq,Ord,Default,Hashable)
 121 instance Show URL where
 122         showsPrec p = showsPrec p . unURL
 123 instance Semigroup URL where
 124         _x <> y = y