Implement FromXML and get Structure parsing from .ixml files

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

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