module Text.XML.HXT.Arrow.Pickle.Xml
where
import Data.Maybe
import Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Control.Arrow.ListArrows
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.Pickle.Schema
data St = St { attributes :: [XmlTree]
, contents :: [XmlTree]
}
data PU a = PU { appPickle :: (a, St) -> St
, appUnPickle :: St -> (Maybe a, St)
, theSchema :: Schema
}
emptySt :: St
emptySt = St { attributes = []
, contents = []
}
addAtt :: XmlTree -> St -> St
addAtt x s = s {attributes = x : attributes s}
addCont :: XmlTree -> St -> St
addCont x s = s {contents = x : contents s}
dropCont :: St -> St
dropCont s = s { contents = drop 1 (contents s) }
getAtt :: String -> St -> Maybe XmlTree
getAtt name s
= listToMaybe $
runLA ( arrL attributes
>>>
isAttr >>> hasName name
) s
getCont :: St -> Maybe XmlTree
getCont s = listToMaybe . contents $ s
pickleDoc :: PU a -> a -> XmlTree
pickleDoc p v
= XN.mkRoot (attributes st) (contents st)
where
st = appPickle p (v, emptySt)
unpickleDoc :: PU a -> XmlTree -> Maybe a
unpickleDoc p t
| XN.isRoot t
= fst . appUnPickle p $ St { attributes = fromJust . XN.getAttrl $ t
, contents = XN.getChildren t
}
| otherwise
= Nothing
xpZero :: PU a
xpZero = PU { appPickle = snd
, appUnPickle = \ s -> (Nothing, s)
, theSchema = scNull
}
xpUnit :: PU ()
xpUnit = xpLift ()
xpLift :: a -> PU a
xpLift x = PU { appPickle = snd
, appUnPickle = \ s -> (Just x, s)
, theSchema = scEmpty
}
xpLiftMaybe :: Maybe a -> PU a
xpLiftMaybe v = (xpLiftMaybe' v) { theSchema = scOption scEmpty }
where
xpLiftMaybe' Nothing = xpZero
xpLiftMaybe' (Just x) = xpLift x
xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b
xpCondSeq pd f pa k
= PU { appPickle = ( \ (b, s) ->
let
a = f b
pb = k a
in
appPickle pa (a, (appPickle pb (b, s)))
)
, appUnPickle = ( \ s ->
let
(a, s') = appUnPickle pa s
in
case a of
Nothing -> appUnPickle pd s
Just a' -> appUnPickle (k a') s'
)
, theSchema = undefined
}
xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b
xpSeq = xpCondSeq xpZero
xpChoice :: PU b -> PU a -> (a -> PU b) -> PU b
xpChoice pb = xpCondSeq pb undefined
xpWrap :: (a -> b, b -> a) -> PU a -> PU b
xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }
xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b
xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }
xpPair :: PU a -> PU b -> PU (a, b)
xpPair pa pb
= ( xpSeq fst pa (\ a ->
xpSeq snd pb (\ b ->
xpLift (a,b)))
) { theSchema = scSeq (theSchema pa) (theSchema pb) }
xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c)
xpTriple pa pb pc
= xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))
where
toTriple ~(a, ~(b, c)) = (a, b, c )
fromTriple ~(a, b, c ) = (a, (b, c))
xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)
xp4Tuple pa pb pc pd
= xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))
where
toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d )
fromQuad ~(a, b, c, d ) = (a, (b, (c, d)))
xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)
xp5Tuple pa pb pc pd pe
= xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))
where
toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e )
fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e))))
xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)
xp6Tuple pa pb pc pd pe pf
= xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))
where
toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f )
fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f)))))
xpText :: PU String
xpText = xpTextDT scString1
xpTextDT :: Schema -> PU String
xpTextDT sc
= PU { appPickle = \ (s, st) -> addCont (XN.mkText s) st
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st)
, theSchema = sc
}
where
unpickleString st
= do
t <- getCont st
s <- XN.getText t
return (Just s, dropCont st)
xpText0 :: PU String
xpText0 = xpText0DT scString1
xpText0DT :: Schema -> PU String
xpText0DT sc
= xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpTextDT sc
where
emptyToNothing "" = Nothing
emptyToNothing x = Just x
xpPrim :: (Read a, Show a) => PU a
xpPrim
= xpWrapMaybe (readMaybe, show) xpText
where
readMaybe :: Read a => String -> Maybe a
readMaybe str
= val (reads str)
where
val [(x,"")] = Just x
val _ = Nothing
xpTree :: PU XmlTree
xpTree = PU { appPickle = \ (s, st) -> addCont s st
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleTree st)
, theSchema = Any
}
where
unpickleTree st
= do
t <- getCont st
return (Just t, dropCont st)
xpOption :: PU a -> PU (Maybe a)
xpOption pa
= PU { appPickle = ( \ (a, st) ->
case a of
Nothing -> st
Just x -> appPickle pa (x, st)
)
, appUnPickle = appUnPickle $
xpChoice (xpLift Nothing) pa (xpLift . Just)
, theSchema = scOption (theSchema pa)
}
xpList :: PU a -> PU [a]
xpList pa
= PU { appPickle = ( \ (a, st) ->
case a of
[] -> st
_:_ -> appPickle pc (a, st)
)
, appUnPickle = appUnPickle $
xpChoice (xpLift []) pa
(\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))
, theSchema = scList (theSchema pa)
}
where
pc = xpSeq head pa (\ x ->
xpSeq tail (xpList pa) (\ xs ->
xpLift (x:xs)))
xpList1 :: PU a -> PU [a]
xpList1 pa
= ( xpWrap (\ (x, xs) -> x : xs
,\ (x : xs) -> (x, xs)
) $
xpPair pa (xpList pa)
) { theSchema = scList1 (theSchema pa) }
xpAlt :: (a -> Int) -> [PU a] -> PU a
xpAlt tag ps
= PU { appPickle = ( \ (a, st) ->
let
pa = ps !! (tag a)
in
appPickle pa (a, st)
)
, appUnPickle = appUnPickle $
( case ps of
[] -> xpZero
pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift
)
, theSchema = scAlts (map theSchema ps)
}
xpElem :: String -> PU a -> PU a
xpElem name pa
= PU { appPickle = ( \ (a, st) ->
let
st' = appPickle pa (a, emptySt)
in
addCont (XN.mkElement (mkName name) (attributes st') (contents st')) st
)
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)
, theSchema = scElem name (theSchema pa)
}
where
unpickleElement st
= do
t <- getCont st
n <- XN.getElemName t
if qualifiedName n /= name
then fail "element name does not match"
else do
let cs = XN.getChildren t
al <- XN.getAttrl t
res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}
return (Just res, dropCont st)
xpAttr :: String -> PU a -> PU a
xpAttr name pa
= PU { appPickle = ( \ (a, st) ->
let
st' = appPickle pa (a, emptySt)
in
addAtt (XN.mkAttr (mkName name) (contents st')) st
)
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st)
, theSchema = scAttr name (theSchema pa)
}
where
unpickleAttr st
= do
a <- getAtt name st
let av = XN.getChildren a
res <- fst . appUnPickle pa $ St {attributes = [], contents = av}
return (Just res, st)
xpAttrImplied :: String -> PU a -> PU (Maybe a)
xpAttrImplied name pa
= xpOption $ xpAttr name pa
xpAttrFixed :: String -> String -> PU ()
xpAttrFixed name val
= ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing
, const val
) $
xpAttr name xpText
) { theSchema = scAttr name (scFixed val) }
xpAddFixedAttr :: String -> String -> PU a -> PU a
xpAddFixedAttr name val pa
= xpWrap ( snd
, (,) ()
) $
xpPair (xpAttrFixed name val) pa
class XmlPickler a where
xpickle :: PU a
instance XmlPickler Int where
xpickle = xpPrim
instance XmlPickler Integer where
xpickle = xpPrim
instance XmlPickler () where
xpickle = xpUnit
instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where
xpickle = xpPair xpickle xpickle
instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where
xpickle = xpTriple xpickle xpickle xpickle
instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where
xpickle = xp4Tuple xpickle xpickle xpickle xpickle
instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where
xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle
instance XmlPickler a => XmlPickler [a] where
xpickle = xpList xpickle
instance XmlPickler a => XmlPickler (Maybe a) where
xpickle = xpOption xpickle