{-# LANGUAGE RankNTypes #-}
module Ideas.Encoding.Encoder
(
getExercise, getOptions, getRequest
, withExercise, getBaseUrl, getQCGen, getScript
, (//), withJSONTerm, withOpenMath
, hasJSONView, addJSONView, jsonEncoding
, termToJSON, jsonToTerm
, hasLatexEncoding, latexPrinter, latexPrinterContext
, latexEncoding, latexEncodingWith
, EncoderX, TypedEncoder
, (<?>), encodeTyped
, DecoderX, TypedDecoder
) where
import Control.Monad.Reader
import Data.Maybe
import Ideas.Common.Library
import Ideas.Encoding.Options
import Ideas.Encoding.Request
import Ideas.Service.FeedbackScript.Parser (Script)
import Ideas.Service.Types
import Ideas.Text.JSON hiding (String)
import Ideas.Text.Latex
import Ideas.Utils.Decoding
import Test.QuickCheck.Random
import qualified Ideas.Common.Rewriting.Term as Term
import qualified Ideas.Text.JSON as JSON
getExercise :: DecoderX a s (Exercise a)
getExercise = reader fst
getOptions :: DecoderX a s Options
getOptions = reader snd
getRequest :: DecoderX a s Request
getRequest = request <$> getOptions
withExercise :: (Exercise a -> DecoderX a s t) -> DecoderX a s t
withExercise = (getExercise >>=)
getBaseUrl :: DecoderX a s String
getBaseUrl = fromMaybe "http://ideas.cs.uu.nl/" . baseUrl <$> getOptions
getQCGen :: DecoderX a s QCGen
getQCGen = fromMaybe (mkQCGen 0) . qcGen <$> getOptions
getScript :: DecoderX a s Script
getScript = script <$> getOptions
withOpenMath :: (Bool -> DecoderX a s t) -> DecoderX a s t
withOpenMath = (fmap useOpenMath getRequest >>=)
withJSONTerm :: (Bool -> DecoderX a s t) -> DecoderX a s t
withJSONTerm = (fmap useJSONTerm getRequest >>=)
(//) :: Decoder env s a -> s -> Decoder env s2 a
p // a = do
env <- ask
runDecoder p env a
jsonProperty :: Id
jsonProperty = describe "Support for JSON encoding" $ newId "json"
hasJSONView :: Exercise a -> Maybe (View JSON a)
hasJSONView = getPropertyF jsonProperty
addJSONView :: View JSON a -> Exercise a -> Exercise a
addJSONView = setPropertyF jsonProperty
jsonEncoding :: InJSON a => Exercise a -> Exercise a
jsonEncoding = addJSONView (makeView fromJSON toJSON)
termToJSON :: Term -> JSON
termToJSON term =
case term of
TVar s -> JSON.String s
TCon s []
| s == trueSymbol -> Boolean True
| s == falseSymbol -> Boolean False
| s == nullSymbol -> Null
TCon s ts
| s == objectSymbol -> Object (f ts)
| otherwise -> Object [("_apply", Array (JSON.String (show s):map termToJSON ts))]
TList xs -> Array (map termToJSON xs)
TNum n -> Number (I n)
TFloat d -> Number (D d)
TMeta n -> Object [("_meta", Number (I (toInteger n)))]
where
f [] = []
f (TVar s:x:xs) = (s, termToJSON x) : f xs
f _ = error "termToJSON"
jsonToTerm :: JSON -> Term
jsonToTerm json =
case json of
Number (I n) -> TNum n
Number (D d) -> TFloat d
JSON.String s -> TVar s
Boolean b -> Term.symbol (if b then trueSymbol else falseSymbol)
Array xs -> TList (map jsonToTerm xs)
Object [("_meta", Number (I n))] -> TMeta (fromInteger n)
Object [("_apply", Array (JSON.String s:xs))] -> TCon (newSymbol s) (map jsonToTerm xs)
Object xs -> TCon objectSymbol (concatMap f xs)
Null -> Term.symbol nullSymbol
where
f (s, x) = [TVar s, jsonToTerm x]
nullSymbol, objectSymbol :: Symbol
nullSymbol = newSymbol "null"
objectSymbol = newSymbol "object"
latexProperty :: Id
latexProperty = describe "Support for LaTeX encoding" $ newId "latex"
newtype F a = F { unF :: a -> Latex }
getF :: Exercise a -> Maybe (F a)
getF = getPropertyF latexProperty
hasLatexEncoding :: Exercise a -> Bool
hasLatexEncoding = isJust . getF
latexPrinter :: Exercise a -> a -> Latex
latexPrinter ex = maybe (toLatex . prettyPrinter ex) unF (getF ex)
latexPrinterContext :: Exercise a -> Context a -> Latex
latexPrinterContext ex ctx =
let def = toLatex (prettyPrinterContext ex ctx)
in fromMaybe def (unF <$> getF ex <*> fromContext ctx)
latexEncoding :: ToLatex a => Exercise a -> Exercise a
latexEncoding = latexEncodingWith toLatex
latexEncodingWith :: (a -> Latex) -> Exercise a -> Exercise a
latexEncodingWith = setPropertyF latexProperty . F
type EncoderX a = Encoder (Exercise a, Options)
type TypedEncoder a b = TypedValue (Type a) -> EncoderX a b
infixr 5 <?>
(<?>) :: (t -> EncoderX a b, Type a t) -> TypedEncoder a b -> TypedEncoder a b
((p, t) <?> q) tv@(val ::: tp) =
case equal tp t of
Just f -> p (f val)
Nothing -> q tv
encodeTyped :: (t -> EncoderX a b) -> Type a t -> TypedEncoder a b
encodeTyped p t = (p, t) <?> fail "Types do not match"
type DecoderX a = Decoder (Exercise a, Options)
type TypedDecoder a s = forall t . Type a t -> Decoder (Exercise a, Options) s t