module Data.XML.Pickle.Basic where
import Control.Applicative ((<$>))
import qualified Control.Category as Cat
import Control.Exception (Exception)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
import Data.XML.Types
data PU t a = PU
{ unpickleTree :: t -> UnpickleResult t a
, pickleTree :: a -> t
}
data UnpickleResult t a = UnpickleError UnpickleError
| NoResult Text
| Result a (Maybe t)
deriving (Functor, Show)
instance Monad (UnpickleResult t) where
return x = Result x Nothing
Result x r >>= f = case f x of
Result y r' -> Result y (if isJust r then r else r')
y -> y
UnpickleError e >>= _ = UnpickleError e
NoResult e >>= _ = NoResult e
data UnpickleError = ErrorMessage Text
| TraceStep (Text, Text) UnpickleError
| Variants [UnpickleError]
deriving (Show, Typeable)
instance Exception UnpickleError
infixl 6 <++>
(<++>) :: (Text, Text) -> UnpickleError -> UnpickleError
(<++>) = TraceStep
mapUnpickleError :: (UnpickleError -> UnpickleError)
-> UnpickleResult t a
-> UnpickleResult t a
mapUnpickleError f (UnpickleError e) = UnpickleError $ f e
mapUnpickleError _ x = x
missing :: String -> UnpickleError
missing e = upe $ "Entity not found: " ++ e
missingE :: String -> UnpickleResult t a
missingE = UnpickleError . missing
upe :: String -> UnpickleError
upe e = ErrorMessage (Text.pack e)
showTr :: (Text, Text) -> String
showTr (name, "") = Text.unpack name
showTr (name, extra) = concat [Text.unpack name , " (", Text.unpack extra, ")"]
printUPE :: UnpickleError -> [String]
printUPE (ErrorMessage m) = [Text.unpack m]
printUPE (TraceStep t es) = ("-> " ++ showTr t) : printUPE es
printUPE (Variants vs) = concat
. zipWith (:) (map (\x -> show x ++ ")") [(1 :: Int)..])
. map (map ( " " ++))
$ (printUPE <$> vs)
ppUnpickleError :: UnpickleError -> String
ppUnpickleError e = "Error while unpickling:\n"
++ unlines (map (" " ++) (printUPE e))
leftoverE :: String -> UnpickleResult t a
leftoverE l = UnpickleError . upe $ "Leftover Entities" ++ if null l then "" else
": " ++ l
child :: Show a => PU a b -> a -> UnpickleResult t b
child xp v = case unpickleTree xp v of
UnpickleError e -> UnpickleError e
NoResult e -> missingE $ Text.unpack e
Result _ (Just es) -> leftoverE $ show es
Result r Nothing -> Result r Nothing
child' :: PU t a -> t -> UnpickleResult t1 a
child' xp v = case unpickleTree xp v of
UnpickleError e -> UnpickleError e
NoResult e -> missingE $ Text.unpack e
Result _ (Just _es) -> leftoverE ""
Result r Nothing -> Result r Nothing
leftover :: Maybe t -> UnpickleResult t ()
leftover = Result ()
remList :: [t] -> Maybe [t]
remList [] = Nothing
remList xs = Just xs
mapError :: (UnpickleError -> UnpickleError) -> PU t a -> PU t a
mapError f xp = PU { unpickleTree = mapUnpickleError f . unpickleTree xp
, pickleTree = pickleTree xp
}
infixl 6 <++.>
(<++.>) :: (Text, Text) -> UnpickleResult t a -> UnpickleResult t a
(<++.>) s = mapUnpickleError (s <++>)
infixr 0 <?>
(<?>) :: (Text, Text) -> PU t a -> PU t a
(<?>) tr = mapError (swapStack tr)
where
swapStack ns (TraceStep _s e) = TraceStep ns e
swapStack _ns e = error $ "Can't replace non-trace step: " ++ show e
(<??>) :: Text -> PU t a -> PU t a
(<??>) tr = mapError (swapStack tr)
where
swapStack ns (TraceStep (_,s) e) = TraceStep (ns,s) e
swapStack _ns e = error $ "Can't replace non-trace step: " ++ show e
infixr 1 <?+>
(<?+>) :: (Text, Text) -> PU t a -> PU t a
(<?+>) tr = mapError (tr <++>)
data UnresolvedEntityException = UnresolvedEntityException
deriving (Typeable, Show)
instance Exception UnresolvedEntityException
ppName :: Name -> String
ppName (Name local ns pre) = let
ns' = case ns of
Nothing -> []
Just ns'' -> ["{", Text.unpack ns'',"}"]
pre' = case pre of
Nothing -> []
Just pre'' -> [Text.unpack pre'',":"]
in concat . concat $ [["\""],ns', pre', [Text.unpack local], ["\""]]
instance Cat.Category PU where
id = PU (\t -> Result t Nothing) id
g . f = PU { pickleTree = pickleTree f . pickleTree g
, unpickleTree = \val -> case unpickleTree f val of
UnpickleError e -> UnpickleError e
NoResult e -> NoResult e
Result resf re -> case unpickleTree g resf of
UnpickleError e -> UnpickleError e
NoResult e -> NoResult e
Result _ (Just _) -> leftoverE ""
Result resg Nothing -> Result resg re
}