{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2015, 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 -- ----------------------------------------------------------------------------- -- $Id: EncoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.EncoderXML ( XMLEncoder , xmlEncoder, encodeState ) where import Data.Char import Data.Maybe import Data.Monoid import Ideas.Common.Library hiding (exerciseId, (:=), alternatives) import Ideas.Common.Utils (Some(..)) import Ideas.Encoding.Encoder import Ideas.Encoding.OpenMathSupport import Ideas.Encoding.RulesInfo (rulesInfoXML) import Ideas.Encoding.StrategyInfo import Ideas.Service.Diagnose import Ideas.Service.FeedbackScript.Syntax import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.OpenMath.Object import Ideas.Text.XML import qualified Ideas.Service.FeedbackText as FeedbackText import qualified Ideas.Service.ProblemDecomposition as PD ----------------- type XMLEncoder a t = Encoder a t XMLBuilder xmlEncoder :: TypedEncoder a XMLBuilder xmlEncoder = (encodeDiagnosis, tDiagnosis) (encodeDecompositionReply, PD.tReply) (encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) (encodeDerivationText, tDerivation tString tContext) (encodeDifficulty, tDifficulty) (encodeMessage, FeedbackText.tMessage) encoderFor (\(val ::: tp) -> case tp of -- meta-information Tag "RuleShortInfo" t -> case equal t (Const Rule) of Just f -> ruleShortInfo // f val Nothing -> fail "rule short info" Tag "RulesInfo" _ -> withExercise $ \ex -> withOpenMath $ \useOM -> pure (rulesInfoXML ex (buildTerm useOM ex)) Tag "elem" t -> tag "elem" (xmlEncoder // (val ::: t)) -- special cases for lists List (Const Rule) -> encodeAsList [ ruleShortInfo // r | r <- val ] List t -> encodeAsList [ xmlEncoder // (a ::: t) | a <- val ] -- standard Tag _ t -> xmlEncoder // (val ::: t) Iso iso t -> xmlEncoder // (to iso val ::: t) Pair t1 t2 -> xmlEncoder // (fst val ::: t1) <> xmlEncoder // (snd val ::: t2) t1 :|: t2 -> case val of Left a -> xmlEncoder // (a ::: t1) Right b -> xmlEncoder // (b ::: t2) Unit -> mempty Const t -> xmlEncoderConst // (val ::: t) _ -> fail $ show tp) xmlEncoderConst :: XMLEncoder a (TypedValue (Const a)) xmlEncoderConst = encoderFor $ \tv@(val ::: tp) -> case tp of SomeExercise -> case val of Some a -> exerciseInfo // a Strategy -> builder (strategyToXML val) Rule -> "ruleid" .=. show val State -> encodeState // val Context -> encodeContext // val Location -> encodeLocation // val Environment -> encodeEnvironment // val Text -> encodeText // val Bool -> string (showBool val) _ -> text tv encodeState :: XMLEncoder a (State a) encodeState = encoderFor $ \st -> element "state" [ if withoutPrefix st then mempty else element "prefix" [string (show (statePrefix st))] , encodeContext // stateContext st ] encodeContext :: XMLEncoder a (Context a) encodeContext = withOpenMath $ \useOM -> exerciseEncoder $ \ex ctx -> maybe (error "encodeContext") (buildTerm useOM ex) (fromContext ctx) <> let values = bindings (withLoc ctx) loc = fromLocation (location ctx) withLoc | null loc = id | otherwise = insertRef (makeRef "location") loc in munless (null values) $ element "context" [ element "item" [ "name" .=. showId tb , case getTermValue tb of term | useOM -> builder (omobj2xml (toOMOBJ term)) _ -> "value" .=. showValue tb ] | tb <- values ] buildTerm :: BuildXML b => Bool -> Exercise a -> a -> b buildTerm useOM ex | useOM = either msg (builder . toXML) . toOpenMath ex | otherwise = tag "expr" . string . prettyPrinter ex where msg s = error ("Error encoding term in OpenMath: " ++ s) encodeLocation :: XMLEncoder a Location encodeLocation = encoderFor $ \loc -> "location" .=. show loc encodeEnvironment :: HasEnvironment env => XMLEncoder a env encodeEnvironment = encoderFor $ \env -> mconcat [ encodeTypedBinding // b | b <- bindings env ] encodeTypedBinding :: XMLEncoder a Binding encodeTypedBinding = withOpenMath $ \useOM -> makeEncoder $ \tb -> tag "argument" $ ("description" .=. showId tb) <> case getTermValue tb of term | useOM -> builder $ omobj2xml $ toOMOBJ term _ -> string (showValue tb) encodeDerivation :: XMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) encodeDerivation = encoderFor $ \d -> let xs = [ (s, a) | (_, s, a) <- triples d ] in xmlEncoder // (xs ::: tList (tPair (tPair tRule tEnvironment) tContext)) encodeDerivationText :: XMLEncoder a (Derivation String (Context a)) encodeDerivationText = encoderFor $ \d -> encodeAsList [ ("ruletext" .=. s) <> encodeContext // a | (_, s, a) <- triples d ] ruleShortInfo :: XMLEncoder a (Rule (Context a)) ruleShortInfo = makeEncoder $ \r -> mconcat [ "name" .=. showId r , "buggy" .=. showBool (isBuggy r) , "arguments" .=. show (length (getRefs r)) , "rewriterule" .=. showBool (isRewriteRule r) ] encodeDifficulty :: XMLEncoder a Difficulty encodeDifficulty = makeEncoder $ \d -> "difficulty" .=. show d encodeText :: XMLEncoder a Text encodeText = encoderFor $ \txt -> mconcat [ encodeItem // item | item <- textItems txt ] where encodeItem = withOpenMath $ \useOM -> exerciseEncoder $ \ex item -> case item of TextTerm a -> fromMaybe (text item) $ do v <- hasTermView ex b <- match v a return (buildTerm useOM ex b) _ -> text item encodeMessage :: XMLEncoder a FeedbackText.Message encodeMessage = encoderFor $ \msg -> element "message" [ case FeedbackText.accept msg of Just b -> "accept" .=. showBool b Nothing -> mempty , encodeText // FeedbackText.text msg ] encodeDiagnosis :: XMLEncoder a (Diagnosis a) encodeDiagnosis = encoderFor $ \diagnosis -> case diagnosis of Buggy env r -> element "buggy" [encodeEnvironment // env, "ruleid" .=. showId r] NotEquivalent s -> if null s then emptyTag "notequiv" else element "notequiv" [ "reason" .=. s ] Similar b st -> element "similar" ["ready" .=. showBool b, encodeState // st] WrongRule b st mr -> element "wrongrule" $ [ "ready" .=. showBool b, encodeState // st ] ++ maybe [] (\r -> ["ruleid" .=. showId r]) mr Expected b st r -> element "expected" ["ready" .=. showBool b, encodeState // st, "ruleid" .=. showId r] Detour b st env r -> element "detour" [ "ready" .=. showBool b, encodeState // st , encodeEnvironment // env, "ruleid" .=. showId r ] Correct b st -> element "correct" ["ready" .=. showBool b, encodeState // st] Unknown b st -> element "unknown" ["ready" .=. showBool b, encodeState // st] encodeDecompositionReply :: XMLEncoder a (PD.Reply a) encodeDecompositionReply = encoderFor $ \reply -> case reply of PD.Ok loc st -> element "correct" [encLoc loc, encodeState // st] PD.Incorrect eq loc st env -> element "incorrect" [ "equivalent" .=. showBool eq , encLoc loc , encodeState // st , encodeEnvironment // env ] where encLoc = tag "location" . text exerciseInfo :: XMLEncoder a (Exercise b) exerciseInfo = encoderFor $ \ex -> mconcat [ "exerciseid" .=. showId ex , "description" .=. description ex , "status" .=. show (status ex) ] ------------------------------------------------ -- helpers encodeAsList :: [XMLEncoder a t] -> XMLEncoder a t encodeAsList = element "list" . map (tag "elem") showBool :: Bool -> String showBool = map toLower . show