Switch error handling to MonadError instead of Either and establish a clearer typology of errors

lib/Data/PositionTree.hs

@@ -12,17 +12,18 @@ module Data.PositionTree (
   ) where
 
 import Control.Monad (foldM)
-import Control.Monad.Except (MonadError)
+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 (Content(..), Element(..), ppContent, showQName)
-import Text.XML.Light.Serializer (FromXML(..), ToXML(..), (.=), expected)
-import Text.InvisiXML.Error (StructureError)
-import Text.InvisiXML.Namespace (addAttr, getAttr, ixml, setChildren)
-import Text.Printf (printf)
-import Text.Read (readEither, readPrec)
+import Text.XML.Light (Content(..), Element(..))
+import Text.XML.Light.Serializer (
+    FromXML(..), ToXML(..), (.=), expectElement, readAttr
+  )
+import Text.InvisiXML.Error (ParsingError(..), StructureError)
+import Text.InvisiXML.Namespace (addAttr, ixml, setChildren)
+import Text.Read (readPrec)
 
 newtype Position = Position {
     getPosition :: Int
@@ -50,14 +51,15 @@ 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
+  fromXML = expectElement "Node" $ \e@(Element {elContent}) ->
+    let value = fromXML [Elem e] in
+    (Range <$> (readAttr "Position" qTo e) <*> value <*> fromXML elContent)
+    `catchError` (pointIfNoTo value)
+    where
+      qTo = ixml "to"
+      pointIfNoTo value e@(MissingAttribute {})
+        | missingQName e == qTo = Point <$> value
+      pointIfNoTo _ e = throwError e
 
 instance ToXML a => ToXML (Node a) where
   toXML (Point p) = toXML p
@@ -69,14 +71,10 @@ 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)
+      addNode positionTree e = addSibling
+        <$> readAttr "Position" (ixml "at") e
+        <*> fromXML [Elem e]
+        <*> return positionTree
 
 instance ToXML a => ToXML (PositionTree a) where
   toXML (PositionTree m) = foldrWithKey nodesToXML [] m

lib/Text/InvisiXML.hs

@@ -18,14 +18,15 @@ import Data.PositionTree as PositionTree (
 import qualified Data.PositionTree as PositionTree (merge)
 import Data.Text (Text)
 import qualified Data.Text as Text (concat, null, pack)
-import Text.InvisiXML.Error (Occurrence(..), StructureError(..), XMLError(..))
+import Text.InvisiXML.Error (
+    ParsingError(..), TagOccurrence(..), StructureError(..), XMLError(..)
+  )
 import Text.InvisiXML.Namespace (prefix, uRI, ixml)
 import Text.XML.Light (
-      Attr(..), Content(..), Element(..), Line, QName(..), node, showCData
-    , showContent
+    Attr(..), Content(..), Element(..), QName(..), node, showCData, showContent
   )
 import Text.XML.Light.Lexer (Token(..), XmlSource, tokens)
-import Text.XML.Light.Serializer (FromXML(..), ToXML(..), expected)
+import Text.XML.Light.Serializer (FromXML(..), ToXML(..), expectElement)
 
 data FrozenElement = FrozenElement {
       frozenName :: QName
@@ -33,11 +34,8 @@ data FrozenElement = FrozenElement {
   } deriving (Show)
 
 instance FromXML FrozenElement where
-  fromXML [Elem (Element {elName, elAttribs})] = Right $ FrozenElement {
-        frozenName = elName
-      , frozenAttrs = elAttribs
-    }
-  fromXML c = expected "FrozenElement" c
+  fromXML = expectElement "FrozenElement" $ \(Element {elName, elAttribs}) ->
+    return $ FrozenElement {frozenName = elName, frozenAttrs = elAttribs}
 
 instance ToXML FrozenElement where
   toXML (FrozenElement {frozenName, frozenAttrs}) =
@@ -53,9 +51,11 @@ data Structure = Structure {
   } deriving (Show)
 
 instance FromXML Structure where
-  fromXML [Elem e]
-    | elName e == ixml "structure" = Structure <$> fromXML (elContent e)
-  fromXML c = expected "Structure" c
+  fromXML = expectElement "Structure" parseStructure
+    where
+      parseStructure e
+        | elName e == ixml "structure" = Structure <$> fromXML (elContent e)
+        | otherwise = throwError . UnexpectedContent "Structure" $ Elem e
 
 instance ToXML Structure where
   toXML (Structure s) = [Elem $ node (ixml "structure") ([Attr ns uRI], toXML s)]
@@ -70,11 +70,6 @@ data InvisiXML = InvisiXML {
     , text :: Text
   }
 
-data TagOccurrence = TagOccurrence {
-      tag :: QName
-    , openLine :: Line
-  }
-
 type Context = Maybe TagOccurrence
 
 data ParsingState = ParsingState {
@@ -142,13 +137,10 @@ restore (context, subStructure) = state $ \parsingState ->
 checkout :: MonadError XMLError m => Context -> Parser m ()
 checkout actual = gets context >>= compareWith actual
   where
-    compareWith (Just (TagOccurrence {tag, openLine})) Nothing =
-      throwError . ClosingUnopen tag $ Line openLine
-    compareWith Nothing (Just (TagOccurrence {tag, openLine})) =
-      throwError . Unclosed tag $ Line openLine
+    compareWith (Just tO) Nothing = throwError $ ClosingUnopen tO
+    compareWith Nothing (Just tO) = throwError $ Unclosed tO
     compareWith (Just tO0) (Just tO1)
-      | tag tO0 /= tag tO1 =
-          throwError $ ClosingDoesntMatch (tag tO0) (tag tO1) (Line $ openLine tO0)
+      | tag tO0 /= tag tO1 = throwError $ Mismatch {open = tO0, close = tO1}
     compareWith _ _ = return ()
 
 parse :: (XmlSource s, MonadError XMLError m) => s -> m InvisiXML

lib/Text/InvisiXML/Error.hs

 module Text.InvisiXML.Error (
       InvisiXMLError(..)
     , Occurrence(..)
+    , ParsingError(..)
     , StructureError(..)
+    , TagOccurrence(..)
     , XMLError(..)
   ) where
 
-import Text.XML.Light (Line, QName)
+import Text.XML.Light (Content, Line, QName)
 
 data Occurrence =
     Line Line
   | EOF
   deriving Show
 
+data TagOccurrence = TagOccurrence {
+      tag :: QName
+    , openLine :: Line
+  }
+  deriving Show
+
 data XMLError =
-    ClosingUnopen QName Occurrence
-  | ClosingDoesntMatch QName QName Occurrence
-  | Unclosed QName Occurrence
+    ClosingUnopen TagOccurrence
+  | Mismatch {
+          open :: TagOccurrence
+        , close :: TagOccurrence
+      }
+  | Unclosed TagOccurrence
+  deriving Show
+
+data ParsingError =
+    UnexpectedContent {
+          expectedData :: String
+        , found :: Content
+      }
+  | BadAttribute {
+          expectedData :: String
+        , badQName :: QName
+        , expectedInfo :: String
+      }
+  | MissingAttribute {
+          expectedData :: String
+        , missingQName :: QName
+      }
+  | WrongNumber {
+          expectedData :: String
+        , expectedNumber :: Int
+        , actualNumber :: Int
+      }
   deriving Show
 
 data StructureError =
@@ -25,5 +57,6 @@ data StructureError =
 
 data InvisiXMLError =
     XMLError XMLError
+  | ParsingError ParsingError
   | StructureError StructureError
   deriving Show

lib/Text/InvisiXML/Namespace.hs

@@ -4,11 +4,9 @@ module Text.InvisiXML.Namespace (
     , prefix
     , ixml
     , addAttr
-    , getAttr
     , setChildren
   ) where
 
-import Data.List (find)
 import Text.XML.Light (Attr(..), Content(..), Element(..), QName(..), add_attr)
 
 uRI :: String
@@ -27,8 +25,5 @@ onContent _ x = x
 addAttr :: Attr -> Content -> Content
 addAttr = onContent . add_attr
 
-getAttr :: QName -> Element -> Maybe String
-getAttr key = fmap attrVal . find ((==) key . attrKey) . elAttribs
-
 setChildren :: [Content] -> Content -> Content
 setChildren elContent = onContent $ \e -> e {elContent}

lib/Text/XML/Light/Serializer.hs

+{-# LANGUAGE FlexibleContexts #-}
 module Text.XML.Light.Serializer (
       FromXML(..)
     , ToXML(..)
     , decode
-    , eitherDecode
     , encode
     , (.=)
-    , expected
+    , expectElement
+    , readAttr
   ) where
 
-import Data.List (intercalate)
-import Text.Printf (printf)
-import Text.XML.Light (Attr(..), Content, QName, parseXML, ppContent)
+import Control.Monad.Except (MonadError(..))
+import Data.List (find, intercalate)
+import Text.Read (readEither)
+import Text.XML.Light (
+    Attr(..), Content(..), Element(..), QName, parseXML, ppContent
+  )
 import Text.XML.Light.Lexer (XmlSource)
+import Text.InvisiXML.Error (ParsingError(..))
 
 class FromXML a where
-  fromXML :: [Content] -> Either String a
+  fromXML :: MonadError ParsingError m => [Content] -> m a
 
 class ToXML a where
   toXML :: a -> [Content]
 
-decode :: (XmlSource s, FromXML a) => s -> Maybe a
-decode = either (\_ -> Nothing) Just . eitherDecode
-
-eitherDecode :: (XmlSource s, FromXML a) => s -> Either String a
-eitherDecode = fromXML . parseXML
+decode :: (XmlSource s, FromXML a, MonadError ParsingError m) => s -> m a
+decode = fromXML . parseXML
 
 encode :: ToXML a => a -> String
 encode = intercalate "\n" . fmap ppContent . toXML
@@ -31,6 +33,16 @@ encode = intercalate "\n" . fmap ppContent . toXML
 (.=) :: Show v => QName -> v -> Attr
 k .= v = Attr k $ show v
 
-expected :: String -> [Content] -> Either String a
-expected elemType =
-  Left . printf "Expected %s but got %s" elemType . concat . fmap ppContent
+expectElement :: MonadError ParsingError m =>
+  String -> (Element -> m a) -> [Content] -> m a
+expectElement _ parser [Elem e] = parser e
+expectElement dataName _ [c] = throwError $ UnexpectedContent dataName c
+expectElement dataName _ l = throwError . WrongNumber dataName 1 $ length l
+
+readAttr :: (MonadError ParsingError m, Read a) => String -> QName -> Element -> m a
+readAttr dataName key =
+  maybe (throwError $ MissingAttribute dataName key)
+        (either (throwError . BadAttribute dataName key)
+                return
+          . readEither . attrVal)
+  . find ((==) key . attrKey) . elAttribs