LslPlus-0.4.0: src/Language/Lsl/Internal/DOMProcessing.hs
module Language.Lsl.Internal.DOMProcessing(ElemAcceptor(..),
findElement,
findOptionalElement,
findOrDefault,
findSimple,
findSimpleOrDefault,
findValueOrDefault,
findBoolOrDefault,
findValue,
findOptionalValue,
findOptionalBool,
valueAcceptor, -- String -> ElemAcceptor m t
ctxelem,
simple,
simpleElement,
matchChoice,
matchMaybe,
cmatch,
match,
attValueString,
acceptList, --
elementList,
elementListWith,
elementsOnly,
attrString,
Content(..),
Document(..),
Element(..),
xmlParse,
--module Text.XML.HaXml,
--module Text.XML.HaXml.Posn
) where
import Data.Maybe
import Control.Monad(MonadPlus(..),liftM2)
import Control.Monad.Error(MonadError(..))
import Language.Lsl.Internal.Util(readM)
import Text.XML.HaXml(Attribute,AttValue(..),Document(..),Element(..),Content(..),Reference(..),xmlParse)
import Text.XML.HaXml.Posn(Posn(..))
data Monad m => ElemAcceptor m t = ElemAcceptor { acceptorTag :: String, acceptorFunc :: (Element Posn -> m t) }
findElement (ElemAcceptor tag acceptor) list =
let find' _ [] = throwError ("element not found: " ++ tag)
find' bs (ce@(CElem (Elem nm _ _) _):cs) | nm == tag =
do val <- ctxelem acceptor ce
return (val, reverse bs ++ cs)
| otherwise = find' (ce:bs) cs
in find' [] list
findOptionalElement (ElemAcceptor tag acceptor) list =
let find' bs [] = return (Nothing,bs)
find' bs (ce@(CElem (Elem nm _ _) _):cs) | nm == tag =
do val <- ctxelem acceptor ce
return (Just val, reverse bs ++ cs)
| otherwise = find' (ce:bs) cs
in find' [] list
findOrDefault def acceptor list =
do (v,rest) <- findOptionalElement acceptor list
return $ case v of Nothing -> (def, rest); Just v' -> (v',rest)
findSimpleOrDefault def tag = findOrDefault def (simpleElement tag)
ctxelem f (CElem e i) = catchError (f e) handler
where handler s = throwError ("at " ++ (show i) ++ ": " ++ s)
cmatch acceptor (CElem e@(Elem n _ _) i) = catchError (match acceptor e) handler
where handler s = throwError ("at " ++ (show i) ++ ": " ++ s)
match acceptor e@(Elem n _ _) | n /= acceptorTag acceptor = throwError ("unexpected element " ++ n ++ " (expected " ++ acceptorTag acceptor ++ ")")
| otherwise = acceptorFunc acceptor e
simple (Elem _ _ []) = return ""
simple (Elem _ _ contents) = return (processContents contents)
simpleElement s = ElemAcceptor s simple
findSimple s = findElement (simpleElement s)
processContents = concatMap processContentItem
processContentItem (CElem (Elem name _ _) _) = error ("unexpected content element (" ++ name ++ ")")
processContentItem (CString _ s _) = s
processContentItem (CRef (RefEntity "lt") _) = "<"
processContentItem (CRef (RefEntity "gt") _) = ">"
processContentItem (CRef (RefEntity "amp") _) = "&"
processContentItem (CRef (RefEntity "quot") _) = "\""
processContentItem (CRef (RefEntity "apos") _) = "'"
processContentItem (CMisc _ _) = error "unexpected content"
matchChoice acceptors (CElem e@(Elem name _ _) i) =
do result <- foldl (liftM2 mplus) (return Nothing) $ map (matchMaybe e) acceptors
case result of
Nothing -> throwError ("at " ++ show i ++ ": unexpected element " ++ name)
Just val -> return val
matchMaybe e@(Elem n a c) (ElemAcceptor name f) | n /= name = return Nothing
| otherwise = f e >>= return . Just
attValueString (AttValue list) = concat [ s | Left s <- list ]
acceptList itemAcceptor (Elem _ _ contents) = mapM (cmatch itemAcceptor) (elementsOnly contents)
elementList name itemAcceptor = ElemAcceptor name (acceptList itemAcceptor)
acceptListWith f (Elem _ _ contents) = mapM f (elementsOnly contents)
elementListWith name f = ElemAcceptor name (acceptListWith f)
elementsOnly cs = [ e | e@(CElem _ _) <- cs]
acceptValue e = do
s <- simple e
value <- readM s
return value
valueAcceptor s = ElemAcceptor s acceptValue
findValue name contents =
do (sval,rest) <- findSimple name contents
value <- readM sval
return (value,rest)
findOptionalValue name contents =
do (v,rest) <- findOptionalElement (simpleElement name) contents
case v of
Nothing -> return (Nothing,contents)
Just s -> do
value <- readM s
return (value, rest)
findOptionalBool name contents =
do (v,rest) <- findOptionalElement (simpleElement name) contents
case v of
Nothing -> return (Nothing,contents)
Just "true" -> return (Just True,rest)
Just "false" -> return (Just False,rest)
Just s -> fail ("unable to parse " ++ s)
findBoolOrDefault def name contents =
do (sval,rest) <- findOptionalElement (simpleElement name) contents
case sval of
Nothing -> return (def,contents)
Just "true" -> return (True,rest)
Just "false" -> return (False,rest)
Just s -> fail ("unable to parse " ++ s)
findValueOrDefault def name contents =
do (sval,rest) <- findOptionalElement (simpleElement name) contents
case sval of
Nothing -> return (def, contents)
Just s -> do
value <- readM s
return (value, rest)
-- for backwards compatibility
attrString (AttValue v) = concatMap decode v
where
decode (Left v) = v
decode (Right (RefEntity ent)) = "&"++ent++";"
decode (Right (RefChar cref)) = "&"++show cref++";"
-- type ContentAcceptor a = [Content Posn] -> Either String a
-- type ContentFinder a = [Content Posn] -> Either String (Maybe a, [Content Posn])
-- type ElementAcceptor a = Element Posn -> Either String a
-- type ElementTester a = Element Posn -> Either String (Maybe a)
-- type AttributeAcceptor a = [Attribute] -> Either String a
-- mustBe :: String -> (b -> a) -> ContentAcceptor b -> ElementAcceptor a
-- mustBe tag f cf (Elem name _ cs) | tag /= name = Left ("expected " ++ tag)
-- | otherwise = case cf cs of
-- Left s -> Left s
-- Right v -> Right (f v)
-- canBe :: String -> (b -> a) -> ContentAcceptor b -> ElementTester a
-- canBe tag f cf (Elem name _ cs) | tag /= name = Right Nothing
-- | otherwise = case cf cs of
-- Left s -> Left s
-- Right v -> Right (Just (f v))
-- mustBeWith :: String -> (a -> b -> c) -> AttributeAcceptor a -> ContentAcceptor b -> ElementAcceptor c
-- mustBeWith tag f af cf (Elem name attrs cs) | tag /= name = Left ("expected " ++ tag)
-- | otherwise = do
-- av <- af attrs
-- cv <- cf cs
-- return (f av cv)
-- canBeWith :: String -> (a -> b -> c) -> AttributeAcceptor a -> ContentAcceptor b -> ElementTester c
-- canBeWith tag f af cf (Elem name attrs cs) | tag /= name = Right Nothing
-- | otherwise = do
-- av <- af attrs
-- cv <- cf cs
-- return (Just (f av cv))
-- liftElemTester :: ((Element Posn) -> Either String (Maybe a)) -> (Content Posn -> Either String (Maybe a))
-- liftElemAcceptor ef (CElem e pos) = case ef e of
-- Left s -> Left ("at " ++ show pos ++ ": " ++ s)
-- Right v -> Right v
--
-- canHaveElem :: ElementAcceptor a -> ContentFinder a
-- canHaveElem ef cs = mapM (\ c -> liftElemAcceptor ef c >>= return . (,) c) cs >>= (\ vs -> case span (isNothing . snd) vs of
-- (bs,[]) -> Right (Nothing,map fst bs)
-- (bs,c:cs) -> Right (snd c,map fst $ bs ++ cs))
--
-- mustHaveElem :: ElementAcceptor a -> ContentFinder a
-- mustHaveElem ef cs = mapM (\ c -> liftElemAcceptor ef c >>= return . (,) c) cs >>= (\ vs -> case span (isNothing . snd) vs of
-- (bs,[]) -> Left ("element not found")
-- (bs,c:cs) -> Right (snd c,map fst $ bs ++ cs))
-- boolContent cs = simpleContent cs >>= (\ v -> case v of
-- "true" -> Right True
-- "false" -> Right False
-- s -> Left ("unrecognized bool " ++ s))
--
-- readableContent :: Read a => ContentAcceptor a
-- readableContent cs = simpleContent cs >>= readM
-- simpleContent :: ContentAcceptor String
-- simpleContent cs = mapM processContentItem cs >>= return . concat
-- where
-- processContentItem (CElem (Elem name _ _) _) = Left ("unexpected content element (" ++ name ++ ")")
-- processContentItem (CString _ s _) = Right s
-- processContentItem (CRef (RefEntity "lt") _) = Right "<"
-- processContentItem (CRef (RefEntity "gt") _) = Right ">"
-- processContentItem (CRef (RefEntity "amp") _) = Right "&"
-- processContentItem (CRef (RefEntity "quot") _) = Right "\""
-- processContentItem (CRef (RefEntity "apos") _) = Right "'"
-- processContentItem (CMisc _ _) = Right "unexpected content"
-- empty :: ContentAcceptor ()
-- empty [] = Right ()
-- empty _ = Left "unexpected content"
-- data FooBar = FooBar { foo :: Int, bar :: String }
-- fooE :: ElementAcceptor Int
-- fooE = mustBe "foo" id readableContent
-- -- foobar = mustBe "FooBar" (\ _ -> FooBar 0 "") ( \ cs -> do
-- mustHave (mustBe "foo"