From 7cd6a0819c63028aaad1c3d1368ff0e31d1ac35a Mon Sep 17 00:00:00 2001
From: Alice BRENON <alice.brenon@ens-lyon.fr>
Date: Mon, 15 Feb 2021 18:13:08 +0100
Subject: [PATCH] Switch error handling to MonadError instead of Either and
establish a clearer typology of errors
---
lib/Data/PositionTree.hs | 44 +++++++++++++++-----------------
lib/Text/InvisiXML.hs | 38 +++++++++++----------------
lib/Text/InvisiXML/Error.hs | 41 ++++++++++++++++++++++++++---
lib/Text/InvisiXML/Namespace.hs | 5 ----
lib/Text/XML/Light/Serializer.hs | 40 +++++++++++++++++++----------
5 files changed, 99 insertions(+), 69 deletions(-)
diff --git a/lib/Data/PositionTree.hs b/lib/Data/PositionTree.hs
index 6838dd5..c411f1c 100644
--- a/lib/Data/PositionTree.hs
+++ b/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
diff --git a/lib/Text/InvisiXML.hs b/lib/Text/InvisiXML.hs
index 3372451..4f6a418 100644
--- a/lib/Text/InvisiXML.hs
+++ b/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
diff --git a/lib/Text/InvisiXML/Error.hs b/lib/Text/InvisiXML/Error.hs
index 4420fa4..9bb3e9e 100644
--- a/lib/Text/InvisiXML/Error.hs
+++ b/lib/Text/InvisiXML/Error.hs
@@ -1,21 +1,53 @@
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
diff --git a/lib/Text/InvisiXML/Namespace.hs b/lib/Text/InvisiXML/Namespace.hs
index 9449141..6dc0e58 100644
--- a/lib/Text/InvisiXML/Namespace.hs
+++ b/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}
diff --git a/lib/Text/XML/Light/Serializer.hs b/lib/Text/XML/Light/Serializer.hs
index fd92aea..25b0a65 100644
--- a/lib/Text/XML/Light/Serializer.hs
+++ b/lib/Text/XML/Light/Serializer.hs
@@ -1,29 +1,31 @@
+{-# 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
--
GitLab