From 3371f3454e798f2bbf6057fc97f30d96a3a86969 Mon Sep 17 00:00:00 2001
From: Alice BRENON <alice.brenon@ens-lyon.fr>
Date: Fri, 12 Feb 2021 18:35:38 +0100
Subject: [PATCH] Implement FromXML and get Structure parsing from .ixml files
---
lib/Data/PositionTree.hs | 44 ++++++++++++++++++++++++++++++++++------
lib/Text/InvisiXML.hs | 14 ++++++++++++-
2 files changed, 51 insertions(+), 7 deletions(-)
diff --git a/lib/Data/PositionTree.hs b/lib/Data/PositionTree.hs
index 797c9c1..6838dd5 100644
--- a/lib/Data/PositionTree.hs
+++ b/lib/Data/PositionTree.hs
@@ -11,18 +11,28 @@ module Data.PositionTree (
, origin
) where
+import Control.Monad (foldM)
import Control.Monad.Except (MonadError)
import Data.Map as Map (Map, alter, foldrWithKey)
import qualified Data.Map as Map (empty)
import qualified Data.Map.Merge.Strict as Map (merge, preserveMissing, zipWithMatched)
import Data.Text as Text (Text, length)
-import Text.XML.Light.Serializer (FromXML(..), ToXML(..), (.=))
+import Text.XML.Light (Content(..), Element(..), ppContent, showQName)
+import Text.XML.Light.Serializer (FromXML(..), ToXML(..), (.=), expected)
import Text.InvisiXML.Error (StructureError)
-import Text.InvisiXML.Namespace (addAttr, ixml, setChildren)
+import Text.InvisiXML.Namespace (addAttr, getAttr, ixml, setChildren)
+import Text.Printf (printf)
+import Text.Read (readEither, readPrec)
newtype Position = Position {
getPosition :: Int
- } deriving (Show, Read, Eq, Ord)
+ } deriving (Eq, Ord)
+
+instance Show Position where
+ show = show . getPosition
+
+instance Read Position where
+ readPrec = Position <$> readPrec
origin :: Position
origin = Position 0
@@ -39,17 +49,39 @@ data Node a =
}
deriving (Show)
+instance FromXML a => FromXML (Node a) where
+ fromXML c@[Elem e] =
+ case getAttr (ixml "to") e of
+ Just to -> Range
+ <$> readEither to
+ <*> fromXML c
+ <*> fromXML (elContent e)
+ _ -> Point <$> fromXML c
+ fromXML c = expected "Node" c
+
instance ToXML a => ToXML (Node a) where
toXML (Point p) = toXML p
- toXML (Range {to = Position p, value, children}) =
- setChildren (toXML children) . addAttr (ixml "to" .= p) <$> toXML value
+ toXML (Range {to, value, children}) =
+ setChildren (toXML children) . addAttr (ixml "to" .= to) <$> toXML value
newtype PositionTree a = PositionTree (Map Position [Node a]) deriving (Show)
+instance FromXML a => FromXML (PositionTree a) where
+ fromXML contents = foldM addNode empty [e | (Elem e) <- contents]
+ where
+ qAt = ixml "at"
+ addNode positionTree e =
+ let c = Elem e in
+ case getAttr qAt e of
+ Just at ->
+ addSibling <$> readEither at <*> fromXML [c] <*> return positionTree
+ Nothing -> Left $ printf
+ "Missing %s attribute on node %s" (showQName qAt) (ppContent c)
+
instance ToXML a => ToXML (PositionTree a) where
toXML (PositionTree m) = foldrWithKey nodesToXML [] m
where
- nodesToXML (Position at) nodes l =
+ nodesToXML at nodes l =
(addAttr (ixml "at" .= at) <$> (toXML =<< nodes)) ++ l
addSibling :: Position -> Node a -> PositionTree a -> PositionTree a
diff --git a/lib/Text/InvisiXML.hs b/lib/Text/InvisiXML.hs
index 8ba68c3..3372451 100644
--- a/lib/Text/InvisiXML.hs
+++ b/lib/Text/InvisiXML.hs
@@ -25,13 +25,20 @@ import Text.XML.Light (
, showContent
)
import Text.XML.Light.Lexer (Token(..), XmlSource, tokens)
-import Text.XML.Light.Serializer (FromXML(..), ToXML(..))
+import Text.XML.Light.Serializer (FromXML(..), ToXML(..), expected)
data FrozenElement = FrozenElement {
frozenName :: QName
, frozenAttrs :: [Attr]
} deriving (Show)
+instance FromXML FrozenElement where
+ fromXML [Elem (Element {elName, elAttribs})] = Right $ FrozenElement {
+ frozenName = elName
+ , frozenAttrs = elAttribs
+ }
+ fromXML c = expected "FrozenElement" c
+
instance ToXML FrozenElement where
toXML (FrozenElement {frozenName, frozenAttrs}) =
[Elem Element {
@@ -45,6 +52,11 @@ data Structure = Structure {
positionTree :: PositionTree FrozenElement
} deriving (Show)
+instance FromXML Structure where
+ fromXML [Elem e]
+ | elName e == ixml "structure" = Structure <$> fromXML (elContent e)
+ fromXML c = expected "Structure" c
+
instance ToXML Structure where
toXML (Structure s) = [Elem $ node (ixml "structure") ([Attr ns uRI], toXML s)]
where
--
GitLab