ideas-1.0: src/Service/ModeXML.hs
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
-- Copyright 2011, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- Services using XML notation
--
-----------------------------------------------------------------------------
module Service.ModeXML
( processXML, xmlRequest, openMathConverterTp, stringFormatConverterTp
, resultOk, resultError, addVersion
) where
import Common.Library hiding (exerciseId)
import Common.Utils (Some(..), readM)
import Common.Utils.Uniplate (transform)
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Service.DomainReasoner
import Service.Evaluator
import Service.FeedbackScript.Syntax
import Service.OpenMathSupport
import Service.Request
import Service.RulesInfo (rulesInfoXML)
import Service.State
import Service.StrategyInfo
import Service.Types
import Text.OpenMath.Object
import Text.OpenMath.Symbol
import Text.XML
import qualified Service.Types as Tp
processXML :: String -> DomainReasoner (Request, String, String)
processXML input = do
xml <- liftEither (parseXML input)
req <- liftEither (xmlRequest xml)
resp <- xmlReply req xml
`catchError` (return . resultError)
vers <- getVersion
let out = showXML (if null vers then resp else addVersion vers resp)
return (req, out, "application/xml")
addVersion :: String -> XML -> XML
addVersion s xml =
let info = [ "version" := s ]
in xml { attributes = attributes xml ++ info }
xmlRequest :: XML -> Either String Request
xmlRequest xml = do
unless (name xml == "request") $
fail "expected xml tag request"
srv <- findAttribute "service" xml
let a = extractExerciseId xml
enc <- case findAttribute "encoding" xml of
Just s -> liftM Just (readEncoding s)
Nothing -> return Nothing
return Request
{ service = srv
, exerciseId = a
, source = findAttribute "source" xml
, dataformat = XML
, encoding = enc
}
xmlReply :: Request -> XML -> DomainReasoner XML
xmlReply request xml = do
srv <- findService (service request)
ex <-
case exerciseId request of
Just code -> findExercise code
Nothing
| service request == "exerciselist" ->
return (Some emptyExercise)
| otherwise ->
fail "unknown exercise code"
Some conv <-
case encoding request of
Just StringEncoding -> return (stringFormatConverter ex)
_ -> return (openMathConverter ex)
res <- evalService conv srv xml
return (resultOk res)
extractExerciseId :: Monad m => XML -> m Id
extractExerciseId = liftM newId . findAttribute "exerciseid"
resultOk :: XMLBuilder -> XML
resultOk body = makeXML "reply" $ do
"result" .=. "ok"
body
resultError :: String -> XML
resultError txt = makeXML "reply" $ do
"result" .=. "error"
element "message" (text txt)
------------------------------------------------------------
-- Mixing abstract syntax (OpenMath format) and concrete syntax (string)
stringFormatConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder)
stringFormatConverter (Some ex) = Some (stringFormatConverterTp ex)
stringFormatConverterTp :: Exercise a -> Evaluator XML XMLBuilder a
stringFormatConverterTp ex =
Evaluator (xmlEncoder False f ex) (xmlDecoder False g ex)
where
f = liftM (element "expr" . text . prettyPrinter ex) . fromContext
g xml0 = do
xml <- findChild "expr" xml0 -- quick fix
-- guard (name xml == "expr")
let input = getData xml
either (fail . show) return (parser ex input)
openMathConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder)
openMathConverter (Some ex) = Some (openMathConverterTp ex)
openMathConverterTp :: Exercise a -> Evaluator XML XMLBuilder a
openMathConverterTp ex =
Evaluator (xmlEncoder True f ex) (xmlDecoder True g ex)
where
f ctx = liftM (builder . toXML) $
case changeT (return . markFocus) ctx >>= leaveT of
Just term | useFocus ->
return (toOMOBJ (term :: Term))
_ ->
fromContext ctx >>= toOpenMath ex
g xml = do
xob <- findChild "OMOBJ" xml
omobj <- liftEither (xml2omobj xob)
case fromOpenMath ex (if useFocus then transform noFocus omobj else omobj) of
Just a -> return a
Nothing -> fail "Invalid OpenMath object for this exercise"
markFocus :: Term -> Term
markFocus = unary (newSymbol focusSymbol)
noFocus :: OMOBJ -> OMOBJ
noFocus (OMA [OMS s, x]) | s == focusSymbol = x
noFocus a = a
focusSymbol = makeSymbol "ideas" "focus"
useFocus = False
xmlEncoder :: Bool -> (Context a -> DomainReasoner XMLBuilder) -> Exercise a -> Encoder XMLBuilder a
xmlEncoder isOM f ex = Encoder
{ encodeType = xmlEncodeType isOM (xmlEncoder isOM f ex) ex
, encodeCtxTerm = f
, encodeTerm = f . inContext ex -- (not so nice)
, encodeTuple = sequence_
}
xmlEncodeType :: Bool -> Encoder XMLBuilder a -> Exercise a -> Type a t -> t -> DomainReasoner XMLBuilder
xmlEncodeType b enc ex serviceType =
case serviceType of
Tp.Tag s t1
| s == "RulesInfo" -> \_ ->
rulesInfoXML ex (encodeTerm enc)
| otherwise ->
case useAttribute t1 of
Just f | s /= "message" -> return . (s .=.) . f
_ -> liftM (element s) . xmlEncodeType b enc ex t1
Tp.Strategy -> return . builder . strategyToXML
Tp.Rule -> return . ("ruleid" .=.) . showId
Tp.Term -> encodeTerm enc
Tp.Context -> encodeContext b (encodeCtxTerm enc)
Tp.Location -> return . ("location" .=.) . show
Tp.ArgValueTp -> return . encodeArgValue b
Tp.Text -> encodeText enc ex
Tp.Bool -> return . text . map toLower . show
Tp.String -> return . text
_ -> encodeDefault enc serviceType
xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> Exercise a -> Decoder XML a
xmlDecoder b f ex = Decoder
{ decodeType = xmlDecodeType b (xmlDecoder b f ex)
, decodeTerm = f
, decoderExercise = ex
}
xmlDecodeType :: Bool -> Decoder XML a -> Type a t -> XML -> DomainReasoner (t, XML)
xmlDecodeType b dec serviceType =
case serviceType of
Tp.Context -> keep $ decodeContext b (decoderExercise dec) (decodeTerm dec)
Tp.Location -> keep $ liftM (read . getData) . findChild "location"
Tp.Id -> keep $ \xml -> do
a <- findChild "location" xml
return (newId (getData a))
Tp.Rule -> keep $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . newId . getData) . findChild "ruleid"
Tp.Term -> keep $ decodeTerm dec
Tp.StrategyCfg -> keep decodeConfiguration
Tp.Script -> keep $ \xml ->
case findAttribute "script" xml of
Just s -> readScript s
Nothing ->
defaultScript (getId (decoderExercise dec))
Tp.Tag s t
| s == "state" -> keep $ \xml -> do
g <- equalM stateType serviceType
st <- decodeState b (decoderExercise dec) (decodeTerm dec) xml
return (g st)
| s == "answer" -> keep $ \xml -> do
c <- findChild "answer" xml
(a, _) <- xmlDecodeType b dec t c
return a
| s == "difficulty" -> keep $ \xml -> do
g <- equalM difficultyType serviceType
a <- findAttribute "difficulty" xml
maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)
{- s == "prefix" -> \xml -> do
f <- equalM String t
mp <- decodePrefix (decoderExercise dec) xml
s <- maybe (fail "no prefix") (return . show) mp
return (f s, xml) -}
| otherwise -> keep $ \xml ->
findChild s xml >>= liftM fst . xmlDecodeType b dec t
_ -> decodeDefault dec serviceType
where
keep :: Monad m => (XML -> m a) -> XML -> m (a, XML)
keep f xml = liftM (\a -> (a, xml)) (f xml)
useAttribute :: Type a t -> Maybe (t -> String)
useAttribute String = Just id
useAttribute Bool = Just (map toLower . show)
useAttribute _ = Nothing
decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a)
decodeState b ex f xmlTop = do
xml <- findChild "state" xmlTop
mpr <- decodePrefix ex xml
term <- decodeContext b ex f xml
return (makeState ex mpr term)
decodePrefix :: Monad m => Exercise a -> XML -> m (Maybe (Prefix (Context a)))
decodePrefix ex xml
| all isSpace prefixText =
return (Just (emptyPrefix str))
| prefixText ~= "no prefix" =
return Nothing
| otherwise = do
a <- readM prefixText
pr <- makePrefix a str
return (Just pr)
where
prefixText = maybe "" getData (findChild "prefix" xml)
str = strategy ex
a ~= b = g a == g b
g = map toLower . filter (not . isSpace)
decodeContext :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (Context a)
decodeContext b ex f xml = do
expr <- f xml
env <- decodeEnvironment b xml
return (makeContext ex env expr)
decodeEnvironment :: Monad m => Bool -> XML -> m Environment
decodeEnvironment b xml =
case findChild "context" xml of
Just this -> foldM add emptyEnv (children this)
Nothing -> return emptyEnv
where
add env item = do
unless (name item == "item") $
fail $ "expecting item tag, found " ++ name item
n <- findAttribute "name" item
case findChild "OMOBJ" item of
-- OpenMath object found inside item tag
Just this | b ->
case xml2omobj this >>= fromOMOBJ of
Left err -> fail err
Right term ->
return (storeEnv n (term :: Term) env)
-- Simple value in attribute
_ -> do
value <- findAttribute "value" item
return (storeEnv n value env)
decodeConfiguration :: MonadPlus m => XML -> m StrategyConfiguration
decodeConfiguration xml =
case findChild "configuration" xml of
Just this -> mapM decodeAction (children this)
Nothing -> fail "no strategy configuration"
where
decodeAction item = do
guard (null (children item))
action <-
case find (\a -> map toLower (show a) == name item) configActions of
Just a -> return a
Nothing -> fail $ "unknown action " ++ show (name item)
cfgloc <- findAttribute "name" item
return (byName (newId cfgloc), action)
encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder
encodeEnvironment b loc env0
| nullEnv env = return ()
| otherwise = element "context" $
forM_ (keysEnv env) $ \k ->
element "item" $ do
"name" .=. k
case lookupEnv k env of
Just term | b -> builder (omobj2xml (toOMOBJ (term :: Term)))
_ -> "value" .=. fromMaybe "" (lookupEnv k env)
where
env | null loc = env0
| otherwise = storeEnv "location" loc env0
encodeContext :: Monad m => Bool -> (Context a -> m XMLBuilder) -> Context a -> m XMLBuilder
encodeContext b f ctx = do
xml <- f ctx
return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx))
encodeArgValue :: Bool -> ArgValue -> XMLBuilder
encodeArgValue b (ArgValue descr a) = element "argument" $ do
"description" .=. labelArgument descr
showValue a
where
showValue
| b = builder . omobj2xml . toOMOBJ . build (termViewArgument descr)
| otherwise = text . showArgument descr
encodeText :: Encoder s a -> Exercise a -> Text -> DomainReasoner s
encodeText enc ex = liftM (encodeTuple enc) . mapM f . textItems
where
f (TextTerm a) = fromMaybe (encodeAsString enc a) $ do
v <- hasTermView ex
b <- match v a
return (encodeTerm enc b)
f a = encodeAsString enc a