ideas-0.7: src/Service/ModeXML.hs
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
-- 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.Library hiding (exerciseId)
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.StrategyInfo
import Service.State
import Service.Diagnose
import Service.Types
import qualified Service.Types as Tp
import Service.Evaluator
import Text.OpenMath.Object
import Text.XML
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` (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)
pkg <-
case exerciseId request of
Just code -> findPackage code
Nothing
| service request == "exerciselist" ->
return (Some (package emptyExercise))
| otherwise ->
fail "unknown exercise code"
Some conv <-
case encoding request of
Just StringEncoding -> return (stringFormatConverter pkg)
_ -> return (openMathConverter pkg)
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 ExercisePackage -> Some (Evaluator XML XMLBuilder)
stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg)
stringFormatConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a
stringFormatConverterTp pkg =
Evaluator (xmlEncoder False f pkg) (xmlDecoder False g pkg)
where
ex = exercise pkg
f = return . element "expr" . text . prettyPrinter ex
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 ExercisePackage -> Some (Evaluator XML XMLBuilder)
openMathConverter (Some pkg) = Some (openMathConverterTp pkg)
openMathConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a
openMathConverterTp pkg =
Evaluator (xmlEncoder True f pkg) (xmlDecoder True g pkg)
where
f = return . builder . toXML . toOpenMath pkg
g xml = do
xob <- findChild "OMOBJ" xml
omobj <- liftEither (xml2omobj xob)
case fromOpenMath pkg omobj of
Just a -> return a
Nothing -> fail "Unknown OpenMath object"
xmlEncoder :: Bool -> (a -> DomainReasoner XMLBuilder) -> ExercisePackage a -> Encoder XMLBuilder a
xmlEncoder b f pkg = Encoder
{ encodeType = xmlEncodeType b (xmlEncoder b f pkg) pkg
, encodeTerm = f
, encodeTuple = sequence_
}
xmlEncodeType :: Bool -> Encoder XMLBuilder a -> ExercisePackage a -> Type a t -> t -> DomainReasoner XMLBuilder
xmlEncodeType b enc pkg serviceType =
case serviceType of
Tp.Tag s _
| s == "Diagnosis" -> \a -> do
d <- isSynonym diagnosisTypeSynonym (a ::: serviceType)
encodeDiagnosis b (encodeTerm enc) d
| s == "DecompositionReply" -> \a -> do
reply <- isSynonym replyTypeSynonym (a ::: serviceType)
encodeReply (encodeState b (encodeTerm enc)) reply
| s == "RulesInfo" -> \_ ->
rulesInfoXML (exercise pkg) (encodeTerm enc)
| s == "State" -> \a -> do
st <- isSynonym stateTypeSynonym (a ::: serviceType)
encodeState b (encodeTerm enc) st
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 (xmlEncodeType b enc pkg t1) xs
let elems = mapM_ (element "elem") bs
return (element "list" elems)
Tp.Tag s t1 -> liftM (element s) . xmlEncodeType b enc pkg t1 -- quick fix
Tp.Strategy -> return . builder . strategyToXML
Tp.Rule -> return . ("ruleid" .=.) . showId
Tp.Term -> encodeTerm enc
Tp.Context -> encodeContext b (encodeTerm enc)
Tp.Location -> return . {-element "location" .-} text . show
Tp.Id -> return . text . show
Tp.Bool -> return . text . map toLower . show
Tp.String -> return . text
Tp.Int -> return . text . show
_ -> encodeDefault enc serviceType
xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> ExercisePackage a -> Decoder XML a
xmlDecoder b f pkg = Decoder
{ decodeType = xmlDecodeType b (xmlDecoder b f pkg)
, decodeTerm = f
, decoderPackage = pkg
}
xmlDecodeType :: Bool -> Decoder XML a -> Type a t -> XML -> DomainReasoner (t, XML)
xmlDecodeType b dec serviceType =
case serviceType of
Tp.Context -> keep $ decodeContext b (decoderPackage 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 -> decodeConfiguration
Tp.Tag s t
| s == "State" -> \xml -> do
g <- equalM stateTp serviceType
st <- decodeState b (decoderPackage dec) (decodeTerm dec) xml
return (g st, xml)
| s == "answer" -> \xml ->
findChild "answer" xml >>= 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)
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 s Bool) = Just $ \b -> [(s, map toLower (show b))]
allAreTagged (Tag s String) = Just $ \a -> [(s, a)]
allAreTagged _ = Nothing
decodeState :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (State a)
decodeState b pkg f xmlTop = do
xml <- findChild "state" xmlTop
unless (name xml == "state") (fail "expected a state tag")
mpr <- decodePrefix pkg xml
term <- decodeContext b pkg f xml
return (makeState pkg mpr term)
decodePrefix :: Monad m => ExercisePackage a -> XML -> m (Maybe (Prefix (Context a)))
decodePrefix pkg 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 (exercise pkg)
a ~= b = g a == g b
g = map toLower . filter (not . isSpace)
decodeContext :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (Context a)
decodeContext b pkg f xml = do
expr <- f xml
env <- decodeEnvironment b xml
return (makeContext (exercise pkg) 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 >>= omobjToTerm of
Left err -> fail err
Right term ->
return (storeEnv n term env)
-- Simple value in attribute
_ -> do
value <- findAttribute "value" item
return (storeEnv n 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 (newId cfgloc), action)
encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder
encodeState b f state = do
body <- f (stateTerm state)
return $ element "state" $ do
encodePrefix (statePrefix state)
let env = getEnvironment (stateContext state)
encodeEnvironment b (location (stateContext state)) env
body
encodePrefix :: Maybe (Prefix a) -> XMLBuilder
encodePrefix = element "prefix" . text . maybe "no prefix" show
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 (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" .=. showId r
NotEquivalent -> return $ tag "notequiv"
Similar b s -> ok "similar" b s Nothing
Expected b s r -> ok "expected" b s (Just (showId r))
Detour b s r -> ok "detour" b s (Just (showId 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" .=.) 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))