diff --git a/lib/Data/PositionTree.hs b/lib/Data/PositionTree.hs index 797c9c16288f81f6f6ef4a427e9128dece5cee94..6838dd5aebcc1ff014001745d2e1673186d1e18e 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 8ba68c3cb6f31c4d6fd7c61939d6f6da1f17b625..3372451581c0af121a7b68e751afd6621af2753f 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