module Data.XML.Pickle.Basic where
import Control.Applicative
import Control.Monad (ap)
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 Applicative (UnpickleResult t) where
pure = return
(<*>) = ap
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 (Variants vs) = concat
. zipWith (:) (map (\x -> show x ++ ")") [(1 :: Int)..])
. map (map ( " " ++))
$ (printUPE <$> vs)
printUPE (TraceStep t es) =
let (n, es') = collapsSteps t es
in ("-> " ++ showTr t
++ if n > 0
then (" [x" ++ show (n+1) ++"]" )
else "")
: printUPE es'
where
collapsSteps t (TraceStep t' ns) | t == t'
= let (n, ns') = collapsSteps t ns
in (n+1, ns')
collapsSteps _ es = (0, es)
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
}