Fix Figure XmlPos.

[doclang.git] / Language / TCT / Write / XML.hs

diff --git a/Language/TCT/Write/XML.hs b/Language/TCT/Write/XML.hs
index 2e203c93ef7e98752672b4dd4431efa0b538c958..7270f86e3bd5cb4fd585a44b76c792c0713dc0ee 100644 (file)
--- a/Language/TCT/Write/XML.hs
+++ b/Language/TCT/Write/XML.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language.TCT.Write.XML where
@@ -16,16 +15,13 @@ import Data.Function (($), (.), id)
 import Data.Functor (Functor(..), (<$>))
 import Data.Maybe (Maybe(..), maybe)
 import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
 import Data.Semigroup (Semigroup(..))
 import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
 import Data.Set (Set)
-import Data.String (IsString(..))
 import Data.Text (Text)
 import Data.TreeSeq.Strict (Tree(..))
 import GHC.Exts (toList)
-import Prelude (error, undefined)
-import Text.Show (Show(..), showChar, showString)
+import Prelude (undefined)
 import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.Sequence as Seq
@@ -34,53 +30,11 @@ import qualified Data.Text.Lazy as TL
 import qualified Language.TCT.Write.Text as Write
 import qualified System.FilePath as FP
 
+import Text.Blaze.XML ()
 import Language.TCT hiding (Parser)
+import Language.XML
 import qualified Data.TreeSeq.Strict as TreeSeq
 
--- * Type 'XML'
-type XML  = Tree (Cell XmlName) (Cell XmlLeaf)
-type XMLs = Seq XML
-
--- ** Type 'XmlName'
-data XmlName
- =   XmlName
- {   xmlNamePrefix :: Text
- ,   xmlNameSpace  :: Text
- ,   xmlNameLocal  :: Text
- }
-instance Show XmlName where
-       showsPrec _p XmlName{xmlNameSpace="", ..} =
-               showString (Text.unpack xmlNameLocal)
-       showsPrec _p XmlName{..} =
-               if Text.null xmlNameSpace
-               then showString (Text.unpack xmlNameLocal)
-               else
-                       showChar '{' .
-                       showString (Text.unpack xmlNameSpace) .
-                       showChar '}' .
-                       showString (Text.unpack xmlNameLocal)
-instance Eq XmlName where
-       XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
-instance Ord XmlName where
-       XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
-instance IsString XmlName where
-       fromString "" = XmlName "" "" ""
-       fromString full@('{':rest) =
-               case List.break (== '}') rest of
-                (_, "")     -> error ("Invalid Clark notation: " <> show full)
-                (ns, local) -> XmlName "" (Text.pack ns) (Text.pack $ List.drop 1 local)
-       fromString local = XmlName "" "" (Text.pack local)
-
-xmlLocalName :: Text -> XmlName
-xmlLocalName = XmlName "" ""
-
--- ** Type 'XmlLeaf'
-data XmlLeaf
- =   XmlAttr    XmlName Text
- |   XmlComment Text
- |   XmlText    Text
- deriving (Eq,Ord,Show)
-
 -- * Type 'InhXml'
 data InhXml
  =   InhXml
@@ -325,10 +279,10 @@ xmlTokens tok = goTokens tok
                                goTokens $
                                        rs |> Cell br er (TokenPlain (Text.dropAround Char.isSpace r))
                         _ -> goTokens toks
-                TokenPair PairHash (toList -> [unCell -> TokenPlain t]) ->
+                TokenPair PairHash to ->
                        Seq.singleton $
                        TreeN (cell "ref") $
-                               xmlAttrs [cell ("to",t)]
+                               xmlAttrs [cell ("to",TL.toStrict $ Write.textTokens to)]
                 TokenPair (PairElem name attrs) ts ->
                        Seq.singleton $
                        TreeN (cell $ xmlLocalName name) $