module Ideas.Encoding.StrategyInfo (strategyToXML, xmlToStrategy) where
import Control.Monad
import Data.Char
import Data.Maybe
import Ideas.Common.Library
import Ideas.Common.Strategy.Abstract
import Ideas.Common.Strategy.Core
import Ideas.Common.Utils (readInt)
import Ideas.Text.XML
strategyToXML :: IsStrategy f => f a -> XML
strategyToXML = coreToXML . toCore . toStrategy
infoToXML :: LabelInfo -> XMLBuilder
infoToXML info = mconcat
[ "name" .=. showId info
, mwhen (removed info) ("removed" .=. "true")
, mwhen (collapsed info) ("collapsed" .=. "true")
, mwhen (hidden info) ("hidden" .=. "true")
]
coreToXML :: Core LabelInfo a -> XML
coreToXML core = makeXML "label" $
case core of
Label l a -> infoToXML l <> coreBuilder infoToXML a
_ -> coreBuilder infoToXML core
coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder
coreBuilder f = rec
where
rec core =
case core of
_ :*: _ -> asList "sequence" isSequence
_ :|: _ -> asList "choice" isChoice
_ :|>: _ -> asList "orelse" isOrElse
_ :%: _ -> asList "interleave" isInterleave
a :@: b -> tag "alternate" (rec a <> rec b)
Label l (Rule r) | getId l == getId r
-> tag "rule" (f l)
Label l a -> tag "label" (f l <> rec a)
Atomic a -> tag "atomic" (rec a)
Let ds a -> tag "let" (decls ds <> rec a)
Rule r -> tag "rule" ("name" .=. show r)
Var n -> tag "var" ("var" .=. show n)
Succeed -> emptyTag "succeed"
Fail -> emptyTag "fail"
where
asList s g = element s (map rec (collect g core))
decls ds = mconcat [ tag "decl" (("var" .=. show n) <> rec a)
| (n, a) <- ds
]
collect :: (a -> Maybe (a, a)) -> a -> [a]
collect f = ($ []) . rec
where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a)
isSequence :: Core l a -> Maybe (Core l a, Core l a)
isSequence (a :*: b) = Just (a, b)
isSequence _ = Nothing
isChoice :: Core l a -> Maybe (Core l a, Core l a)
isChoice (a :|: b) = Just (a, b)
isChoice _ = Nothing
isOrElse :: Core l a -> Maybe (Core l a, Core l a)
isOrElse (a :|>: b) = Just (a, b)
isOrElse _ = Nothing
isInterleave :: Core l a -> Maybe (Core l a, Core l a)
isInterleave (a :%: b) = Just (a, b)
isInterleave _ = Nothing
xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) -> XML -> m (Strategy a)
xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g
where
g info = case f (showId info) of
Just r -> return r
Nothing -> fail $ "Unknown rule: " ++ showId info
xmlToInfo :: Monad m => XML -> m LabelInfo
xmlToInfo xml = do
n <- findAttribute "name" xml
let boolAttr s = fromMaybe False (findBool s xml)
return (makeInfo n)
{ removed = boolAttr "removed"
, collapsed = boolAttr "collapsed"
, hidden = boolAttr "hidden"
}
findBool :: Monad m => String -> XML -> m Bool
findBool attr xml = do
s <- findAttribute attr xml
case map toLower s of
"true" -> return True
"false" -> return False
_ -> fail "not a boolean"
readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a)
readStrategy toLabel findRule xml = do
xs <- mapM (readStrategy toLabel findRule) (children xml)
let s = name xml
case lookup s table of
Just f -> f s xs
Nothing ->
fail $ "Unknown strategy combinator " ++ show s
where
buildSequence _ xs
| null xs = return Succeed
| otherwise = return (foldr1 (:*:) xs)
buildChoice _ xs
| null xs = return Fail
| otherwise = return (foldr1 (:|:) xs)
buildOrElse _ xs
| null xs = return Fail
| otherwise = return (foldr1 (:|>:) xs)
buildInterleave _ xs
| null xs = return Succeed
| otherwise = return (foldr1 (:%:) xs)
buildLabel x = do
info <- toLabel xml
return (Label info x)
buildRule = do
info <- toLabel xml
r <- findRule info
return (Label info (Rule r))
buildVar = do
s <- findAttribute "var" xml
i <- maybe (fail "var: not an int") return (readInt s)
return (Var i)
comb0 a _ [] = return a
comb0 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 0 args"
comb1 f _ [x] = return (f x)
comb1 _ s _ = fail $ "Strategy combinator " ++ s ++ "expects 1 arg"
join2 f g a b = join (f g a b)
table =
[ ("sequence", buildSequence)
, ("choice", buildChoice)
, ("orelse", buildOrElse)
, ("interleave", buildInterleave)
, ("label", join2 comb1 buildLabel)
, ("atomic", comb1 Atomic)
, ("rule", join2 comb0 buildRule)
, ("var", join2 comb0 buildVar)
, ("succeed", comb0 Succeed)
, ("fail", comb0 Fail)
]