{-# LANGUAGE GADTs #-}
module Ideas.Encoding.DecoderXML
( XMLDecoder, xmlDecoder
) where
import Control.Applicative hiding (Const)
import Control.Monad.State hiding (State)
import Data.Char
import Ideas.Common.Library
import Ideas.Common.Traversal.Navigator
import Ideas.Encoding.Encoder
import Ideas.Encoding.OpenMathSupport
import Ideas.Encoding.Request hiding (XML)
import Ideas.Service.State
import Ideas.Service.Types
import Ideas.Text.MathML
import Ideas.Text.OpenMath.Object
import Ideas.Text.XML
type XMLDecoder a t = DecoderX a XML t
xmlDecoder :: TypedDecoder a XML
xmlDecoder tp =
case tp of
Tag s (Const String) ->
decodeChild s decodeData
`mplus`
decodeAttribute s
Tag s t
| s == "answer" ->
decodeChild "answer" (xmlDecoder t)
| s == "Difficulty" -> do
g <- equalM tDifficulty tp
a <- decodeAttribute "difficulty"
maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)
| otherwise ->
decodeChild s (xmlDecoder t)
Iso p t -> from p <$> xmlDecoder t
List t -> do
x <- xmlDecoder t
xs <- xmlDecoder (List t)
return (x:xs)
`mplus`
return []
Pair t1 t2 -> do
x <- xmlDecoder t1
y <- xmlDecoder t2
return (x, y)
t1 :|: t2 ->
(Left <$> xmlDecoder t1) `mplus`
(Right <$> xmlDecoder t2)
Unit -> return ()
Const ctp ->
case ctp of
State -> decodeState
Context -> decodeContext
Rule -> decodeRule
Environment -> decodeArgEnvironment
Term -> get >>= (fromXML >=> fromOMOBJ)
Location -> decodeLocation
StratCfg -> decodeConfiguration
QCGen -> getQCGen
Script -> getScript
Exercise -> getExercise
Id ->
decodeChild "location" $
gets (newId . getData)
MathML -> decodeMathML
String -> decodeData
XML -> get
_ -> fail $ "No support for argument type in XML: " ++ show tp
_ -> fail $ "No support for argument type in XML: " ++ show tp
decodeRule :: XMLDecoder a (Rule (Context a))
decodeRule = decodeChild "ruleid" $ do
ex <- getExercise
get >>= getRule ex . newId . getData
decodeLocation :: XMLDecoder a Location
decodeLocation = decodeChild "location" $
gets (toLocation . read . getData)
decodeState :: XMLDecoder a (State a)
decodeState = decodeChild "state" $ do
ex <- getExercise
ps <- decodePaths
ctx <- decodeContext
let prf = replayPaths ps (strategy ex) ctx
return (makeState ex prf ctx)
decodePaths :: XMLDecoder a [Path]
decodePaths = do
prefixText <- gets (maybe "" getData . findChild "prefix")
if all isSpace prefixText
then return [emptyPath]
else if prefixText ~= "no prefix"
then return []
else readPaths prefixText
where
a ~= b = g a == g b
g = map toLower . filter (not . isSpace)
decodeContext :: XMLDecoder a (Context a)
decodeContext = do
ex <- getExercise
expr <- decodeExpression
env <- decodeEnvironment
let ctx = setEnvironment env (inContext ex expr)
locRef = makeRef "location"
case locRef ? env of
Just s -> maybe (fail "invalid location") return $ do
loc <- toLocation <$> readM s
navigateTo loc (deleteRef locRef ctx)
Nothing ->
return ctx
decodeExpression :: XMLDecoder a a
decodeExpression = withOpenMath f
where
f True = decodeOMOBJ
f False = decodeChild "expr" $ do
ex <- getExercise
get >>= either fail return . parser ex . getData
decodeOMOBJ :: XMLDecoder a a
decodeOMOBJ = decodeChild "OMOBJ" $ get >>= \xml -> do
ex <- getExercise
omobj <- fromXML xml
case fromOpenMath ex omobj of
Just a -> return a
Nothing -> fail "Invalid OpenMath object for this exercise"
decodeMathML :: XMLDecoder a MathML
decodeMathML = decodeFirstChild "math" $ get >>= fromXML
decodeEnvironment :: XMLDecoder a Environment
decodeEnvironment =
decodeChild "context" (get >>= foldM add mempty . children)
<|> return mempty
where
add env item = do
unless (name item == "item") $
fail $ "expecting item tag, found " ++ name item
n <- findAttribute "name" item
req <- getRequest
case findChild "OMOBJ" item of
Just this | useOpenMath req ->
case xml2omobj this >>= fromOMOBJ of
Left err -> fail err
Right term ->
return $ insertRef (makeRef n) (term :: Term) env
_ -> do
value <- findAttribute "value" item
return $ insertRef (makeRef n) value env
decodeConfiguration :: XMLDecoder a StrategyCfg
decodeConfiguration = decodeChild "configuration" $
get >>= \xml ->
mconcat <$> mapM decodeAction (children xml)
where
decodeAction item = do
guard (null (children item))
action <- readM (name item)
cfgloc <- findAttribute "name" item
return (action `byName` newId cfgloc)
decodeArgEnvironment :: XMLDecoder a Environment
decodeArgEnvironment = get >>=
fmap makeEnvironment . mapM (decodeBinding //) . findChildren "argument"
decodeBinding :: XMLDecoder a Binding
decodeBinding = get >>= \xml -> do
a <- findAttribute "description" xml
req <- getRequest
case findChild "OMOBJ" xml of
Just this | useOpenMath req ->
case xml2omobj this >>= fromOMOBJ of
Left err -> fail err
Right term -> return (termBinding a term)
_ -> return (makeBinding (makeRef a) (getData xml))
where
termBinding :: String -> Term -> Binding
termBinding = makeBinding . makeRef