module Data.XML.Pickle (
PU(..)
, Attribute
, pickle
, unpickle
, xpUnit
, xpZero
, xpThrow
, xpId
, xpTrees
, xpHead
, xpTree
, xpText0
, xpText
, xpRoot
, xpPrim
, xpAttr
, xpAttrImplied
, xpAttrFixed
, xpElem
, xpElemWithName
, xpElemByNamespace
, xpElemVerbatim
, xpElemAttrs
, xpElemNodes
, xpElemBlank
, xpElemExists
, xpElems
, xpContent
, xpOption
, xpDefault
, xpWithDefault
, xpMap
, xpAlt
, xpEither
, xpTryCatch
, xpFindMatches
, xpAll
, xpSubsetAll
, xpList0
, xpSeqWhile
, xpList
, xp2Tuple
, xpPair
, (<#>)
, xp3Tuple
, xpTriple
, xp4Tuple
, xp5Tuple
, xp6Tuple
, xpWrap
, xpWrapEither
, xpWrapMaybe
, xpWrapMaybe_
, xpAssert
, xpUnliftElems
, xpIsolate
, xpPeek
, xpClean
, xpRecursiveClean
, UnpickleError(..)
, (<++>)
, (<?+>)
, (<?>)
, UnresolvedEntityException(..)
, flattenContent
) where
import Control.Applicative ((<$>))
import Control.Arrow
import qualified Control.Category as Cat
import Data.Either
import Data.List(partition)
import Data.Monoid(Monoid, mempty)
import Control.Exception
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
import Data.XML.Types
data UnpickleError = ErrorMessage Text
| TraceStep (Text, Text) UnpickleError
| Variants [UnpickleError]
deriving Typeable
upe :: String -> UnpickleError
upe e = ErrorMessage (Text.pack e)
replace :: [(Text,Text)] -> [(Text,Text)] -> [(Text,Text)]
replace ns ss = go ns ss
where
go [] ss = ss
go (n:ns) (s:ss) = n : (go ns ss)
go ns s = error $ "Empty list while trying to replace " ++
show ss ++ " with " ++ show ns
swapStack ns (TraceStep s e) = TraceStep ns e
swapStack ns e = error $ "Can't replace non-trace step" ++ show e
showTr (name, "") = Text.unpack name
showTr (name, extra) = concat [Text.unpack name , " (", Text.unpack extra, ")"]
printUPE (ErrorMessage m) = [Text.unpack m]
printUPE (TraceStep t es) = ("-> " ++ showTr t) : printUPE es
printUPE (Variants vs) = concat
. zipWith (:) (map (\x -> show x ++ ")") [1..])
. (map $ map ( " " ++))
$ (printUPE <$> vs)
instance Show UnpickleError where
show e = "Error while unpickling:\n" ++ (unlines $ map (" " ++) (printUPE e))
instance Exception UnpickleError
data PU t a = PU
{ unpickleTree :: t
-> Either UnpickleError (a, (Maybe t, Bool))
, pickleTree :: a -> t
}
mapError f xp = PU { unpickleTree = mapLeft f . unpickleTree xp
, pickleTree = pickleTree xp
}
infixl 6 <++>
(<++>) :: (Text, Text) -> UnpickleError -> UnpickleError
(<++>) s e = TraceStep s e
infixr 0 <?>
(<?>) tr = mapError (swapStack tr)
infixr 1 <?+>
(<?+>) 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], ["\""]]
pickle :: PU t a -> a -> t
pickle = pickleTree
unpickle :: PU t a -> t -> Either UnpickleError a
unpickle xp x = fst <$> unpickleTree xp x
for :: [a] -> (a -> b) -> [b]
for = flip map
mapLeft _ (Right r) = Right r
mapLeft f (Left l ) = Left $ f l
type Attribute = (Name,[Content])
xpId :: PU a a
xpId = PU (\t -> Right (t, (Nothing,True))) id
xpTrees :: PU a a
xpTrees = xpId
xpHead :: PU [a] a
xpHead = PU {unpickleTree = \t -> case t of
[] -> Left $ ("xpHead","") <++> upe "No element remaining"
t:ts -> Right (t , (if null ts then Nothing else Just ts, True))
, pickleTree = return
}
xpTree :: PU [a] a
xpTree = xpHead
xpText0 :: PU Text Text
xpText0 = xpId
xpAssert :: Text -> (a -> Bool) -> PU t a -> PU t a
xpAssert err p xp = PU { unpickleTree = \t -> case unpickleTree xp t of
Left e -> Left $ ("xpAssert",err) <++> e
Right (r,c) -> case p r of
True -> Right (r,c)
False -> Left $ assertErr
, pickleTree = pickleTree xp
}
where
assertErr = ("xpAssert",err) <++> upe "Assertion failed"
xpText :: PU Text Text
xpText = ("xpText","") <?> xpAssert "Input is empty" Text.null xpText0
xpRoot ::PU [a] b -> PU a b
xpRoot pa = PU
{ unpickleTree = \t -> case unpickleTree pa [t] of
Left l -> Left $ ("xpRoot","") <++> l
Right (a,(Nothing,True)) -> Right (a, (Nothing,True ))
Right (a,(_ ,_ )) -> Right (a, (Nothing,False))
, pickleTree = \t -> case pickleTree pa t of
[t1] -> t1
_ -> error "pickler called by xpRoot must output exactly one element"
}
getFirst :: (t -> Bool) -> [t] -> Maybe (t, [t])
getFirst _ [] = Nothing
getFirst p (x:xs) = case p x of
True -> Just (x,xs)
False -> (second (x:)) <$> getFirst p xs
xpAttr :: Name -> PU Text a -> PU [Attribute] a
xpAttr name pu = PU
{ unpickleTree = doUnpickle
, pickleTree = \value -> [(name, [ContentText $ pickleTree pu value])]
}
where
tr = ("xpAttr" , Text.pack $ ppName name)
doUnpickle attrs = case getFirst ((== name) . fst) attrs of
Nothing -> Left $ tr <++> upe ("attribute not found")
Just ((_,[ContentText x]), rem) -> case unpickleTree pu x of
Left e -> Left $ tr <++> e
Right (y,(_,c)) -> let rem' = if null rem then Nothing else Just rem
in Right (y,(rem',c))
_ -> Left $ tr <++> upe ("Unresolved entities in " ++ ppName name ++ ".")
xpAttrImplied :: Name -> PU Text a -> PU [Attribute] (Maybe a)
xpAttrImplied name pu = xpOption $ xpAttr name pu
xpAttrFixed :: Name -> Text -> PU [Attribute] ()
xpAttrFixed name val =
xpWrapMaybe_ ("expected fixed attribute "++ ppName name++"="++show val)
(\v -> if v == val then Just () else Nothing) (const val) $
xpAttr name xpId
xpAddFixedAttr :: Name -> Text -> PU [Attribute] b -> PU [Attribute] b
xpAddFixedAttr name val pa
= xpWrap snd ((,) ()) $
xp2Tuple (xpAttrFixed name val) pa
flattenContent :: [Node] -> [Node]
flattenContent xs = case foldr (\x (buf, res) -> case x of
NodeContent (ContentText txt)
-> (txt : buf, res)
e@(NodeElement _)
-> ([] , e : addConcatText buf res)
_ -> throw UnresolvedEntityException
) ([], []) xs
of
(buf, res) -> addConcatText buf res
where
nc = NodeContent . ContentText
addConcatText [] = id
addConcatText xs = (nc (Text.concat xs) :)
xpElem :: Name
-> PU [Attribute] a
-> PU [Node] n
-> PU [Node] (a,n)
xpElem name attrP nodeP = PU
{ unpickleTree = doUnpickleTree
, pickleTree = \(a,n) -> [NodeElement $ Element name
(pickleTree attrP a)
(pickleTree nodeP n)
]
} where
doUnpickleTree nodes = case getFirst (nodeElementNameHelper name) nodes of
Just ((NodeElement (Element _ attrs children)), rem) ->
case unpickleTree attrP attrs of
Left e -> Left $ tr <++> e
Right (x,(_,ca)) -> case unpickleTree nodeP
$ flattenContent children of
Left e -> Left $ tr <++> e
Right (y,(_,cc)) ->
let rem' = if null rem then Nothing else Just rem
in Right ((x,y), (rem' , ca && cc))
_ -> Left $ tr <++> upe "Element not found"
tr = ("xpElem", Text.pack $ ppName name)
nodeElementNameHelper name (NodeElement (Element n _ _)) = n == name
nodeElementNameHelper _ _ = False
xpElems :: Name
-> PU [Attribute] a
-> PU [Node] n
-> PU [Node] [(a, n)]
xpElems name attrs children = PU { unpickleTree = \t ->
let (targets, rest) = partition isThisElem t
rest' = if null rest then Nothing else Just rest
in
case unpickleTree (xpAll $ xpElem name attrs children) targets of
Left e -> Left $ tr <++> e
Right (r, (_, c)) -> Right (r,(rest', c && not (null rest)))
, pickleTree = pickleTree (xpAll $ xpElem name attrs children)
}
where
isThisElem (NodeElement (Element name _ _)) = True
isThisElem _ = False
tr = ("xpElems", Text.pack $ ppName name)
xpSubsetAll :: (a -> Bool)
-> PU [a] b
-> PU [a] [b]
xpSubsetAll pred xp = PU { unpickleTree = \t ->
let (targets, rest) = partition pred t
rest' = if null rest then Nothing else Just rest
in
case unpickleTree (xpAll xp) targets of
Left e -> Left $ ("xpSubsetAll","") <++> e
Right (r, (_, c)) ->
Right (r,(rest', c && not (null rest)))
, pickleTree = pickleTree (xpAll $ xp)
}
xpElemWithName :: PU [Attribute] a
-> PU [Node] n
-> PU [Node] (Name,a,n)
xpElemWithName attrP nodeP = PU
{ unpickleTree = doUnpickleTree
, pickleTree = \(name, a,n) -> [NodeElement $ Element name
(pickleTree attrP a)
(pickleTree nodeP n)
]
} where
doUnpickleTree nodes = case getFirst nodeElementHelper nodes of
Just ((NodeElement (Element name attrs children)), rem) ->
case unpickleTree attrP attrs of
Left e -> Left $ tr <++> e
Right (x,(_,ca)) -> case unpickleTree nodeP $
flattenContent children of
Left e -> Left $ tr <++> e
Right (y,(_,cc)) ->
let rem' = if null rem then Nothing else Just rem
in Right ((name,x,y), (rem' , ca && cc))
_ -> Left $ tr <++> upe "No element found"
tr = ("xpElemWithName", "")
nodeElementHelper (NodeElement (Element _ _ _)) = True
nodeElementHelper _ = False
xpElemByNamespace :: Text
-> PU Text name
-> PU [Attribute] a
-> PU [Node] n
-> PU [Node] (name,a,n)
xpElemByNamespace ns nameP attrP nodeP = PU
{ unpickleTree = doUnpickleTree
, pickleTree = \(name, a,n) -> [NodeElement $ Element
(Name (pickleTree nameP name) (Just ns) Nothing)
(pickleTree attrP a)
(pickleTree nodeP n)
]
} where
doUnpickleTree nodes = case getFirst (nodeElementNSHelper ns) nodes of
Just ((NodeElement (Element name attrs children)), rem) ->
case (do
(name' , (_, cn)) <- unpickleTree nameP (nameLocalName name)
(attrs', (_, ca)) <- unpickleTree attrP attrs
(nodes', (_, cns)) <- unpickleTree nodeP nodes
return ((name', attrs', nodes')
,(if null rem then Nothing else Just rem, cn && ca && cns))
) of
Left e -> Left $ (tr $ ppName name) <++> e
Right r -> Right r
_ -> Left $ (tr "") <++> upe "No element found"
tr a = ("xpElemByNamespace", if null a then ns
else Text.concat [ns, " ; ", Text.pack a])
nodeElementNSHelper ns (NodeElement (Element n _ _)) = nameNamespace n == Just ns
nodeElementNSHelper ns _ = False
xpElemVerbatim :: PU [Node] (Element)
xpElemVerbatim = PU
{ unpickleTree = doUnpickleTree
, pickleTree = \e -> [NodeElement e]
} where
doUnpickleTree nodes = case getFirst nodeElementHelper nodes of
Just ((NodeElement e@(Element _ _ _)), rem) ->
let rem' = if null rem then Nothing else Just rem
in Right (e, (rem', True))
_ -> Left $ ("xpElemVerbatim","") <++> upe "no element found."
nodeElementHelper (NodeElement (Element _ _ _)) = True
nodeElementHelper _ = False
xpElemAttrs :: Name -> PU [Attribute] b -> PU [Node] b
xpElemAttrs name puAttrs = xpWrap (fst) (\a -> (a,())) $
xpElem name puAttrs xpUnit
xpElemNodes :: Name -> PU [Node] b -> PU [Node] b
xpElemNodes name puChildren = xpWrap (snd) (\a -> ((),a)) $
xpElem name xpUnit puChildren
xpElemBlank :: Name -> PU [Node] ()
xpElemBlank name = xpWrap (const () ) (const ((),())) $
xpElem name xpUnit xpUnit
xpElemExists :: Name -> PU [Node] Bool
xpElemExists name = xpWrap (\x -> case x of Nothing -> False; Just _ -> True)
(\x -> if x then Just () else Nothing) $
xpOption (xpElemBlank name)
xpContent :: PU Text a -> PU [Node] a
xpContent xp = ("xpContent","") <?+> PU
{ unpickleTree = doUnpickle
, pickleTree = return . NodeContent . ContentText . pickleTree xp
} where
doUnpickle nodes = case getFirst nodeContentHelper nodes of
Just ((NodeContent (ContentText t)), rem) -> case unpickleTree xp t of
Right (a,(_,c)) -> Right (a, (if null rem then Nothing else Just rem,c))
Left l -> Left l
Just ((NodeContent (ContentEntity t)), _) ->
Left . upe $ "Unresolved entity" ++ show t ++ "."
_ -> Left $ upe "No content found"
nodeContentHelper (NodeContent _) = True
nodeContentHelper _ = False
xpUnliftElems :: PU [Node] a -> PU [Element] a
xpUnliftElems xp = PU
{ unpickleTree = doUnpickle
, pickleTree = nodesToElems . pickleTree xp
}
where
doUnpickle nodes = case unpickleTree xp (map NodeElement nodes) of
Left e -> Left $ ("xpUnliftElems","") <++> e
Right (a,(r,c)) -> let r' = case r of
Nothing -> Nothing
Just rs' -> case nodesToElems rs' of
[] -> Nothing
rs -> Just rs
in Right (a,(r', c))
nodesToElems = foldr (\n es -> case n of
NodeElement e -> e : es
_ -> es) []
xpOption :: PU [t] a -> PU [t] (Maybe a)
xpOption pu = PU {
unpickleTree = Right . doUnpickle,
pickleTree = \mValue ->
case mValue of
Just value -> pickleTree pu value
Nothing -> []
}
where
doUnpickle t =
case unpickleTree pu t of
Right (val, (rest, clean)) -> ((Just val), (rest, clean))
Left _ -> (Nothing, (Just t, True))
xpDefault :: (Eq a) => a -> PU [t] a -> PU [t] a
xpDefault df
= xpWrap (fromMaybe df)
(\ x -> if x == df then Nothing else Just x)
.
xpOption
xpWithDefault :: a -> PU t a -> PU t a
xpWithDefault a pa = xpTryCatch pa (lift a)
where
lift a = PU
{ unpickleTree = \t -> Right (a, (Just t, True))
, pickleTree = error "xpWithDefault impossible"
}
getRest :: (a, (Maybe [r], c)) -> (a, ([r], c))
getRest (l, (Just r, c)) = (l,(r, c))
getRest (l, (Nothing, c)) =(l,([], c))
xpUnit :: PU [a] ()
xpUnit = PU (\x -> Right ((), (Just x, True))) (const [])
xp2Tuple :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)
xp2Tuple xp1 xp2 = ("xp2Tuple","") <?+>
PU {pickleTree = \(t1, t2) ->
pickleTree xp1 t1 ++ pickleTree xp2 t2
, unpickleTree = doUnpickleTree
} where
doUnpickleTree r0 = do
(x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0
(x2 ,(r ,c2)) <- unpickleTree xp2 r1
return ((x1,x2),(r,c1 && c2))
xpPair :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)
xpPair l r = ("xpPair", "") <?> xp2Tuple l r
(<#>) :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)
(<#>) l r = ("(<#>)","") <?> xp2Tuple l r
xp3Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)
xp3Tuple xp1 xp2 xp3 = ("xp3Tuple","") <?+>
PU {pickleTree = \(t1, t2, t3) ->
pickleTree xp1 t1
++ pickleTree xp2 t2
++ pickleTree xp3 t3
, unpickleTree = doUnpickleTree
} where
doUnpickleTree r0 = do
(x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0
(x2 ,(r2,c2)) <- getRest <$> unpickleTree xp2 r1
(x3 ,(r ,c3)) <- unpickleTree xp3 r2
return ((x1,x2,x3),(r, c1 && c2 && c3))
xpTriple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)
xpTriple l m r = ("xpTriple","") <?> xp3Tuple l m r
xp4Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] a4
-> PU [a] (a1, a2, a3,a4)
xp4Tuple xp1 xp2 xp3 xp4
= ("xp4Tuple","") <?+>
PU {pickleTree = \(t1, t2, t3, t4) ->
pickleTree xp1 t1
++ pickleTree xp2 t2
++ pickleTree xp3 t3
++ pickleTree xp4 t4
, unpickleTree = doUnpickleTree
} where
doUnpickleTree r0 = do
(x1 ,(r1, c1)) <- getRest <$> unpickleTree xp1 r0
(x2 ,(r2, c2)) <- getRest <$> unpickleTree xp2 r1
(x3 ,(r3, c3)) <- getRest <$> unpickleTree xp3 r2
(x4 ,(r , c4)) <- unpickleTree xp4 r3
return ((x1,x2,x3,x4),(r, c1 && c2 && c3 && c4))
xp5Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] a4 -> PU [a] a5
-> PU [a] (a1, a2, a3, a4, a5)
xp5Tuple xp1 xp2 xp3 xp4 xp5
= ("xp5Tuple","") <?+>
PU {pickleTree = \(t1, t2, t3, t4, t5) ->
pickleTree xp1 t1
++ pickleTree xp2 t2
++ pickleTree xp3 t3
++ pickleTree xp4 t4
++ pickleTree xp5 t5
, unpickleTree = doUnpickleTree
} where
doUnpickleTree r0 = do
(x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0
(x2 ,(r2,c2)) <- getRest <$> unpickleTree xp2 r1
(x3 ,(r3,c3)) <- getRest <$> unpickleTree xp3 r2
(x4 ,(r4,c4)) <- getRest <$> unpickleTree xp4 r3
(x5 ,(r ,c5)) <- unpickleTree xp5 r4
return ((x1,x2,x3,x4,x5),(r, c1 && c2 && c3 && c4 && c5))
xp6Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] a4 -> PU [a] a5
-> PU [a] a6
-> PU [a] (a1, a2, a3, a4, a5, a6)
xp6Tuple xp1 xp2 xp3 xp4 xp5 xp6
= ("xp6Tuple","") <?+>
PU {pickleTree = \(t1, t2, t3, t4, t5, t6) ->
pickleTree xp1 t1
++ pickleTree xp2 t2
++ pickleTree xp3 t3
++ pickleTree xp4 t4
++ pickleTree xp5 t5
++ pickleTree xp6 t6
, unpickleTree = doUnpickleTree
} where
doUnpickleTree r0 = do
(x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0
(x2 ,(r2,c2)) <- getRest <$> unpickleTree xp2 r1
(x3 ,(r3,c3)) <- getRest <$> unpickleTree xp3 r2
(x4 ,(r4,c4)) <- getRest <$> unpickleTree xp4 r3
(x5 ,(r5,c5)) <- getRest <$> unpickleTree xp5 r4
(x6 ,(r ,c6)) <- unpickleTree xp6 r5
return ((x1,x2,x3,x4,x5,x6),(r, c1 && c2 && c3 && c4 && c5 && c6))
xpPeek :: PU t a -> PU t a
xpPeek xp = PU { pickleTree = pickleTree xp
, unpickleTree = \xs ->
case unpickleTree xp xs of
Left e -> Left e
Right (r,(_,c)) -> Right (r,(Just xs,c))
}
xpIsolate :: PU [t] a -> PU [t] a
xpIsolate xp = ("xpIsolate","") <?+>
PU { pickleTree = pickleTree xp
, unpickleTree = \xs -> case xs of
[] -> Left $ upe "No elements left"
(x:xs) -> case unpickleTree xp [x] of
Left l -> Left l
Right (v,(r,c)) -> Right (v,(handleRest r xs, c))
} where
handleRest r xs = case mbToList r ++ xs of [] -> Nothing; rs -> Just rs
mbToList Nothing = []
mbToList (Just r) = r
xpWrap :: (a -> b) -> (b -> a) -> PU t a -> PU t b
xpWrap to from xp = ("xpWrap","") <?+>
PU { unpickleTree = \x -> (first to) <$> unpickleTree xp x
, pickleTree = pickleTree xp . from
}
xpPrim :: (Show a, Read a) => PU Text a
xpPrim = PU { unpickleTree = \x -> case reads $ Text.unpack x of
[] -> Left $ ("xpPrim","") <++>
upe ("Couldn't read " ++ show x ++ ".")
(r,rest):_ -> Right (r,(Nothing, True))
, pickleTree = Text.pack . show
}
xpFindMatches :: PU [b] a -> PU [b] [a]
xpFindMatches xp = PU { unpickleTree = doUnpickleTree
, pickleTree = \xs -> pickleTree xp =<< xs
} where
doUnpickleTree xs =
let (ls, rs) = partitionEithers . for xs $ \x ->
case unpickleTree xp [x] of
Left _ -> Left x
Right (r,(_,c)) -> Right (r, c)
in Right (fst <$> rs, (if null ls then Nothing else Just ls,all snd rs))
xpAll :: PU [a] b -> PU [a] [b]
xpAll xp = PU { unpickleTree = \x ->
let Right (xs, (rs,c)) = unpickleTree (xpFindMatches xp) x
in case rs of
Just (_:_) -> Left $ ("xpAll","") <++>
upe "not all Elements matched"
_ -> Right (xs, (Nothing,c))
, pickleTree = \xs -> pickleTree xp =<< xs
}
xpList0 :: PU [a] b -> PU [a] [b]
xpList0 = xpAll
xpListMinLen :: Int -> PU [a] b -> PU [a] [b]
xpListMinLen ml = xpWrapEither testLength id . xpList
where
testLength as
| length as < ml = Left $ "Expecting at least " ++ show ml ++ " elements"
testLength as = Right as
xpSeqWhile :: PU [a] b -> PU [a] [b]
xpSeqWhile pu = PU {
unpickleTree = Right . doUnpickle,
pickleTree = \t -> (pickleTree pu) =<< t
}
where
doUnpickle [] = ([],(Nothing,True))
doUnpickle es@(elt:rem) =
case unpickleTree pu [elt] of
Right (val,(_,c)) -> let (xs,(r,c')) = doUnpickle rem in
(val:xs,(r,c && c'))
Left _ -> ([],(Just es,True))
xpList :: PU [a] b -> PU [a] [b]
xpList = xpSeqWhile
xpMap :: Ord k =>
Name
-> Name
-> PU Text k
-> PU [Node] a
-> PU [Node] (M.Map k a)
xpMap en an xpk xpv
= xpWrap M.fromList
M.toList
$
xpAll $
xpElem en
(xpAttr an xpk)
xpv
xpWrapMaybe :: (a -> Maybe b) -> (b -> a) -> PU t a -> PU t b
xpWrapMaybe a2b b2a pua = ("xpWrapMaybe","") <?>
xpWrapMaybe_ "xpWrapMaybe can't encode Nothing" a2b b2a pua
xpWrapMaybe_ :: String -> (a -> Maybe b) -> ( b -> a) -> PU t a -> PU t b
xpWrapMaybe_ errorMsg a2b b2a pua = PU {
unpickleTree = \t -> case unpickleTree pua t of
Right (val, rest) ->
case a2b val of
Just val' -> Right (val', rest)
Nothing -> Left $ ("xpWrapMaybe_","") <++> upe errorMsg
Left err -> Left err,
pickleTree = \value -> pickleTree pua (b2a value)
}
xpWrapEither :: (a -> Either String b) -> (b -> a) -> PU t a -> PU t b
xpWrapEither a2b b2a pua = ("xpWrapEither","") <?+>
PU {
unpickleTree = \t -> case unpickleTree pua t of
Right (val, rest) -> mapLeft upe $ (flip (,) rest) <$> a2b val
Left err -> Left err,
pickleTree = \value -> pickleTree pua (b2a value)
}
xpAlt :: (a -> Int)
-> [PU t a]
-> PU t a
xpAlt selector picklers = PU {
unpickleTree = doUnpickle,
pickleTree = \value -> pickleTree (picklers !! (selector value)) value
}
where
doUnpickle t =
let tryAll [] = Left []
tryAll (x:xs) =
case unpickleTree x t of
Right r -> Right r
Left err -> case tryAll xs of
Left errs -> Left $ err : errs
Right r -> Right r
in case tryAll picklers of
Left errs -> Left $ ("xpAlt","") <++> Variants errs
Right r -> Right r
xpEither :: PU n t1 -> PU n t2 -> PU n (Either t1 t2)
xpEither xpl xpr = PU {
unpickleTree = doUnpickle,
pickleTree = \v -> case v of
Left l -> pickleTree xpl l
Right r -> pickleTree xpr r
}
where
doUnpickle t = case unpickleTree xpl t of
Right (val, rst) -> Right (Left val, rst)
Left errl -> case unpickleTree xpr t of
Right (val, rst) -> Right (Right val, rst)
Left errr -> Left $ ("xpEither","")
<++> Variants [errl, errr]
xpTryCatch :: PU t a -> PU t a -> PU t a
xpTryCatch pu1 pu2 = PU
{ unpickleTree = \t -> case unpickleTree pu1 t of
Right (val1, rest) -> Right (val1, rest)
Left err1 -> case unpickleTree pu2 t of
Right (val2, rest) -> Right (val2, rest)
Left err2 -> Left $ ("xpTryCatch","")
<++> Variants [err1, err2]
, pickleTree = pickleTree pu1
}
xpZero :: PU [t] a
xpZero = ("xpZero","") <?> xpThrow "got xpZero"
xpThrow :: String
-> PU [t] a
xpThrow msg = PU
{ unpickleTree = \t -> Left $ ("xpThrow",Text.pack msg) <++> upe msg
, pickleTree = const []
}
xpClean :: PU t a -> PU t a
xpClean xp = PU { unpickleTree = \x -> case unpickleTree xp x of
Left l -> Left l
Right (y, (Nothing, c )) -> Right (y, (Nothing, c ))
_ -> Left $ ("xpClean","") <++> upe "not clean"
, pickleTree = pickleTree xp
}
xpRecursiveClean :: PU t a -> PU t a
xpRecursiveClean xp = PU { unpickleTree = \x -> case unpickleTree xp x of
Left l -> Left l
Right (_, (Just _, _)) ->
Left $ ("xpRecursiveClean","") <++> upe "not clean"
Right (_, (Nothing, False)) ->
Left $ ("xpRecursiveClean","") <++> upe "not recursively clean"
Right (y , (Nothing, True)) -> Right (y , (Nothing, True))
, pickleTree = pickleTree xp
}
instance Cat.Category PU where
id = xpId
g . f = PU { pickleTree = pickleTree f . pickleTree g
, unpickleTree = \val -> case unpickleTree f val of
Left e -> Left e
Right (resf , (rem, cg)) -> case unpickleTree g resf of
Left e -> Left e
Right (resg, (_, cf)) -> Right (resg, (rem, cg && cf))
}