ideas-0.6: src/Service/ModeXML.hs
{-# OPTIONS -XGADTs #-}
-----------------------------------------------------------------------------
-- Copyright 2010, 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.Navigator
import Common.Context
import Common.Exercise
import Common.Strategy hiding (not, fail)
import Common.Utils (Some(..), readM)
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Service.ExercisePackage
import Service.ProblemDecomposition
import Service.Request
import Service.RulesInfo (rulesInfoXML)
import Service.ServiceList
import Service.StrategyInfo
import Service.TypedAbstractService hiding (exercise)
import Service.Diagnose
import Service.Types hiding (State)
import Text.OpenMath.Object
import Text.XML
import qualified Common.Transformation as Rule
import qualified Service.Types as Tp
import Service.DomainReasoner
processXML :: String -> DomainReasoner (Request, String, String)
processXML input = do
xml <- liftEither (parseXML input)
req <- liftEither (xmlRequest xml)
resp <- xmlReply req xml
`catchError` \msg -> return (resultError msg)
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 code = extractExerciseCode xml
enc <- case findAttribute "encoding" xml of
Just s -> liftM Just (readEncoding s)
Nothing -> return Nothing
return Request
{ service = srv
, exerciseID = code
, source = findAttribute "source" xml
, dataformat = XML
, encoding = enc
}
xmlReply :: Request -> XML -> DomainReasoner XML
xmlReply request xml
| service request == "mathdox" = do
code <- maybe (fail "unknown exercise code") return (exerciseID request)
Some pkg <- findPackage code
(st, sloc, answer) <- liftEither $ xmlToRequest xml (fromOpenMath pkg) (exercise pkg)
return (replyToXML (toOpenMath pkg) (problemDecomposition st sloc answer))
xmlReply request xml = do
srv <- findService (service request)
pkg <-
case exerciseID request of
Just code -> findPackage code
Nothing
| service request == "exerciselist" ->
return (Some (package emptyExercise))
| otherwise ->
fail "unknown exercise code"
Some conv <- return $
case encoding request of
Just StringEncoding -> stringFormatConverter pkg
_ -> openMathConverter pkg
res <- liftEither $ evalService conv srv xml
return (resultOk res)
extractExerciseCode :: Monad m => XML -> m ExerciseCode
extractExerciseCode xml =
case liftM (break (== '.')) (findAttribute "exerciseid" xml) of
Just (as, _:bs) -> return (makeCode as bs)
Just (as, _) -> maybe (fail "invalid code") return (readCode as)
-- being backwards compatible with early MathDox
Nothing -> do
let getName = map toLower . filter isAlphaNum . getData
linalg = return . makeCode "linalg"
case fmap getName (findChild "strategy" xml) of
Just name
| name == "gaussianelimination" -> linalg "gaussianelim"
| name == "gramschmidt" -> linalg "gramschmidt"
| name == "solvelinearsystem" -> linalg "linsystem"
| name == "solvelinearsystemwithmatrix" -> linalg "systemwithmatrix"
_ -> fail "no exerciseid attribute, nor a known strategy element"
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 ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder)
stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg)
stringFormatConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a
stringFormatConverterTp pkg =
Evaluator (xmlEncoder False f ex) (xmlDecoder False g pkg)
where
ex = exercise pkg
f = return . element "expr" . text . prettyPrinter ex
g xml = do
xml <- findChild "expr" xml -- quick fix
-- guard (name xml == "expr")
let input = getData xml
either (fail . show) return (parser ex input)
openMathConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder)
openMathConverter (Some pkg) = Some (openMathConverterTp pkg)
openMathConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a
openMathConverterTp pkg =
Evaluator (xmlEncoder True f ex) (xmlDecoder True g pkg)
where
ex = exercise pkg
f = return . builder . toXML . toOpenMath pkg
g xml = do
xob <- findChild "OMOBJ" xml
omobj <- xml2omobj xob
case fromOpenMath pkg omobj of
Just a -> return a
Nothing -> fail "Unknown OpenMath object"
xmlEncoder :: Monad m => Bool -> (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a
xmlEncoder b f ex = Encoder
{ encodeType = encode (xmlEncoder b f ex) ex
, encodeTerm = f
, encodeTuple = sequence_
}
where
encode :: Monad m => Encoder m XMLBuilder a -> Exercise a -> Type a t -> t -> m XMLBuilder
encode enc ex serviceType =
case serviceType of
Tp.List t1 -> \xs ->
case allAreTagged t1 of
Just f -> do
let make = element "elem" . mapM_ (uncurry (.=.)) . f
let elems = mapM_ make xs
return (element "list" elems)
_ -> do
bs <- mapM (encode enc ex t1) xs
let elems = mapM_ (element "elem") bs
return (element "list" elems)
Tp.Elem t1 -> liftM (element "elem") . encode enc ex t1
Tp.Tag s t1 -> liftM (element s) . encode enc ex t1 -- quick fix
Tp.Strategy -> return . builder . strategyToXML
Tp.Rule -> return . ("ruleid" .=.) . Rule.name
Tp.RulesInfo -> \_ -> rulesInfoXML ex (encodeTerm enc)
Tp.Term -> encodeTerm enc
Tp.Diagnosis -> encodeDiagnosis b (encodeTerm enc)
Tp.Context -> encodeContext b (encodeTerm enc)
Tp.Location -> return . {-element "location" .-} text . show
Tp.Bool -> return . text . map toLower . show
Tp.String -> return . text
Tp.Int -> return . text . show
Tp.State -> encodeState b (encodeTerm enc)
_ -> encodeDefault enc serviceType
xmlDecoder :: MonadPlus m => Bool -> (XML -> m a) -> ExercisePackage a -> Decoder m XML a
xmlDecoder b f pkg = Decoder
{ decodeType = decode (xmlDecoder b f pkg)
, decodeTerm = f
, decoderPackage = pkg
}
where
decode :: MonadPlus m => Decoder m XML a -> Type a t -> XML -> m (t, XML)
decode dec serviceType =
case serviceType of
Tp.State -> decodeState b (decoderExercise dec) (decodeTerm dec)
Tp.Location -> leave $ liftM (read . getData) . findChild "location"
Tp.Rule -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid"
Tp.Term -> \xml -> decodeTerm dec xml >>= \a -> return (a, xml)
Tp.StrategyCfg -> decodeConfiguration
_ -> decodeDefault dec serviceType
leave :: Monad m => (XML -> m a) -> XML -> m (a, XML)
leave f xml = liftM (\a -> (a, xml)) (f xml)
allAreTagged :: Type a t -> Maybe (t -> [(String, String)])
allAreTagged (Iso _ f t) = fmap (. f) (allAreTagged t)
allAreTagged (Pair t1 t2) = do
f1 <- allAreTagged t1
f2 <- allAreTagged t2
return $ \(a,b) -> f1 a ++ f2 b
allAreTagged (Tag tag Bool) = Just $ \b -> [(tag, map toLower (show b))]
allAreTagged (Tag tag String) = Just $ \s -> [(tag, s)]
allAreTagged _ = Nothing
decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a, XML)
decodeState b ex f top = do
xml <- findChild "state" top
unless (name xml == "state") (fail "expected a state tag")
mpr <- case maybe "" getData (findChild "prefix" xml) of
prefixText
| all isSpace prefixText ->
return (Just (emptyPrefix (strategy ex)))
| prefixText ~= "no prefix" ->
return Nothing
| otherwise -> do
a <- readM prefixText
pr <- makePrefix a (strategy ex)
return (Just pr)
expr <- f xml
env <- decodeEnvironment b xml
let state = State ex mpr term
term = makeContext ex env expr
return (state, top)
where
a ~= b = g a == g b
g = map toLower . filter (not . isSpace)
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
name <- findAttribute "name" item
case findChild "OMOBJ" item of
-- OpenMath object found inside item tag
Just this | b -> do
case xml2omobj this >>= omobjToTerm of
Left err -> fail err
Right term ->
return (storeEnv name term env)
-- Simple value in attribute
_ -> do
value <- findAttribute "value" item
return (storeEnv name value env)
decodeConfiguration :: MonadPlus m => XML -> m (StrategyConfiguration, XML)
decodeConfiguration xml =
case findChild "configuration" xml of
Just this -> mapM decodeAction (children this) >>= \xs -> return (xs, xml)
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 cfgloc, action)
encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder
encodeState b f state = f (term state) >>= \body -> return $
element "state" $ do
element "prefix" (text $ maybe "no prefix" show (prefix state))
let env = getEnvironment (context state)
encodeEnvironment b (location (context state)) env
body
encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder
encodeEnvironment b loc env0
| nullEnv env = return ()
| otherwise = element "context" $ do
forM_ (keysEnv env) $ \k -> do
element "item" $ do
"name" .=. k
case lookupEnv k env of
Just term | b -> builder (omobj2xml (termToOMOBJ term))
_ -> "value" .=. fromMaybe "" (lookupEnv k env)
where
env | null loc = env0
| otherwise = storeEnv "location" loc env0
encodeDiagnosis :: Monad m => Bool -> (a -> m XMLBuilder) -> Diagnosis a -> m XMLBuilder
encodeDiagnosis mode f diagnosis =
case diagnosis of
Buggy r -> return $ element "buggy" $ "ruleid" .=. Rule.name r
NotEquivalent -> return $ tag "notequiv"
Similar b s -> ok "similar" b s Nothing
Expected b s r -> ok "expected" b s (Just r)
Detour b s r -> ok "detour" b s (Just r)
Correct b s -> ok "correct" b s Nothing
where
ok t b s mr = do
body <- encodeState mode f s
return $ element t $ do
"ready" .=. map toLower (show b)
maybe (return ()) (("ruleid" .=.) . Rule.name) mr
body
encodeContext :: Monad m => Bool -> (a -> m XMLBuilder) -> Context a -> m XMLBuilder
encodeContext b f ctx = do
a <- fromContext ctx
xml <- f a
return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx))