479 lines
No EOL
14 KiB
Elm
479 lines
No EOL
14 KiB
Elm
port module App exposing (..)
|
|
|
|
import Browser
|
|
import Dict exposing (Dict)
|
|
import Html as H exposing (Html)
|
|
import Html.Keyed
|
|
import Html.Attributes as HA
|
|
import Html.Events as HE
|
|
import Json.Decode as JD
|
|
import Json.Decode.Pipeline as JDP exposing (required, requiredAt)
|
|
import Json.Encode as JE exposing (Value)
|
|
import Tuple exposing (pair, first, second)
|
|
|
|
port sendMessage : Value -> Cmd msg
|
|
port receiveMessage : (Value -> msg) -> Sub msg
|
|
port receiveClick : (Value -> msg) -> Sub msg
|
|
|
|
main = Browser.element
|
|
{ init = init
|
|
, update = update
|
|
, subscriptions = subscriptions
|
|
, view = view
|
|
}
|
|
|
|
type alias Exam =
|
|
{ object : JE.Value
|
|
, currentQuestion : Int
|
|
, questions : List Question
|
|
}
|
|
|
|
type alias Question =
|
|
{ isDirty : Bool
|
|
, score : Float
|
|
, object : JE.Value
|
|
, name : String
|
|
, parts : List Part
|
|
, number : Int
|
|
, statement : JE.Value
|
|
}
|
|
|
|
type alias QuestionMessage =
|
|
{ questionNumber : Int
|
|
, type_ : String
|
|
, msg : JE.Value
|
|
}
|
|
|
|
type PartType
|
|
= InformationOnlyPart
|
|
| NumberEntryPart
|
|
| MathematicalExpressionPart
|
|
| PatternMatchPart
|
|
| GapFillPart
|
|
| CustomPart String
|
|
|
|
type alias Part =
|
|
{ object : JE.Value
|
|
, name : String
|
|
, type_ : PartType
|
|
, path : String
|
|
, score : Float
|
|
, marks: Float
|
|
, prompt : JE.Value
|
|
, marking_feedback : List FeedbackMessage
|
|
, gaps : Gaps
|
|
}
|
|
|
|
type Gaps = Gaps (List Part)
|
|
|
|
type alias FeedbackMessage =
|
|
{ op : String
|
|
, credit : Maybe Float
|
|
, message : JE.Value
|
|
, reason : Maybe String
|
|
, credit_change : Maybe String
|
|
}
|
|
|
|
type alias PartMessage =
|
|
{ partPath : String
|
|
, type_ : String
|
|
, msg : JE.Value
|
|
}
|
|
|
|
type ViewMode
|
|
= ViewWholeExam
|
|
| ViewQuestion Int
|
|
| ViewPart Int String
|
|
| ViewPartAnswer Int String
|
|
|
|
decode_default : JD.Decoder a -> a -> JE.Value -> a
|
|
decode_default decoder default =
|
|
JD.decodeValue decoder >> Result.withDefault default
|
|
|
|
decode_view_mode =
|
|
JD.field "mode" JD.string
|
|
|> JD.andThen (\mode -> case mode of
|
|
"exam" -> JD.succeed ViewWholeExam
|
|
"question" -> JD.field "questionNumber" JD.int |> JD.map ViewQuestion
|
|
"part" ->
|
|
JD.map2
|
|
ViewPart
|
|
(JD.field "questionNumber" JD.int)
|
|
(JD.field "partPath" JD.string)
|
|
"part_answer" ->
|
|
JD.map2
|
|
ViewPartAnswer
|
|
(JD.field "questionNumber" JD.int)
|
|
(JD.field "partPath" JD.string)
|
|
_ -> JD.fail <| "Unrecognised view mode: "++mode
|
|
)
|
|
|
|
type alias Model =
|
|
{ exam : Maybe Exam
|
|
, messages : List String
|
|
, view_mode : ViewMode
|
|
}
|
|
|
|
init_model : JE.Value -> Model
|
|
init_model flags =
|
|
let
|
|
exam =
|
|
JD.decodeValue (JD.field "exam" JD.value) flags
|
|
|> Result.toMaybe
|
|
|> Maybe.map (\e ->
|
|
{ object = e
|
|
, currentQuestion = -1
|
|
, questions = get_questions e
|
|
}
|
|
)
|
|
|
|
view_mode =
|
|
JD.decodeValue
|
|
(JD.field "view_mode" decode_view_mode)
|
|
flags
|
|
|> Result.withDefault ViewWholeExam
|
|
in
|
|
{ exam = exam
|
|
, messages = []
|
|
, view_mode = view_mode
|
|
}
|
|
|
|
type Msg
|
|
= ReceiveMessage Value
|
|
| SendPartMessage Question Part String (List (String, JE.Value))
|
|
|
|
init : JE.Value -> (Model, Cmd msg)
|
|
init flags = (init_model flags, Cmd.none)
|
|
|
|
listGet : Int -> List a -> Maybe a
|
|
listGet i = List.drop i >> List.head
|
|
|
|
decode_message =
|
|
JD.map2 pair
|
|
(JD.field "type" JD.string)
|
|
(JD.field "arg" JD.value)
|
|
|
|
update msg model = case msg of
|
|
ReceiveMessage value ->
|
|
case JD.decodeValue decode_message value of
|
|
Ok (kind,arg) -> ({ model | messages = if kind /= "showTiming" then kind::model.messages else model.messages } |> handle_exam_message kind arg, Cmd.none)
|
|
Err s -> ({ model | messages = (Debug.toString s)::model.messages }, Cmd.none)
|
|
|
|
SendPartMessage question part msgtype extras ->
|
|
(model, sendMessage (encode_part_message question part msgtype extras))
|
|
|
|
encode_message msgtype extras =
|
|
JE.object
|
|
([("msgtype", JE.string msgtype)]++extras)
|
|
|
|
encode_question_message question msgtype extras =
|
|
encode_message "question" [ ("msg", JE.object ([("msgtype", JE.string msgtype)]++extras)), ("questionNumber", JE.int question.number) ]
|
|
|
|
encode_part_message question part msgtype extras =
|
|
encode_question_message question "part" [ ("msg", JE.object ([("msgtype", JE.string msgtype)]++extras)), ("partPath", JE.string part.path)]
|
|
|
|
{- update the ith item in a list using the given map function -}
|
|
update_list : Int -> (a -> a) -> List a -> List a
|
|
update_list i fn list = list |> List.indexedMap pair |> List.map (\(j,a) -> if i==j then fn a else a)
|
|
|
|
map_exam : (Exam -> Exam) -> Model -> Model
|
|
map_exam fn model = { model | exam = Maybe.map fn model.exam }
|
|
|
|
map_question : Int -> (Question -> Question) -> Model -> Model
|
|
map_question i fn model = model |> map_exam (\exam -> { exam | questions = update_list i fn exam.questions })
|
|
|
|
map_part : String -> (Part -> Part) -> Question -> Question
|
|
map_part path fn question = { question | parts = List.map (\p -> if p.path==path then fn p else p) question.parts }
|
|
|
|
show_question : Model -> Model
|
|
show_question model =
|
|
case model.exam of
|
|
Nothing -> model
|
|
Just exam -> case JD.decodeValue (JD.field "currentQuestionNumber" JD.int) exam.object of
|
|
Ok n ->
|
|
let
|
|
nexam = { exam | currentQuestion = n }
|
|
in
|
|
{model | exam = Just nexam}
|
|
Err _ -> model
|
|
|
|
update_question_list = map_exam (\e -> {e | questions = get_questions e.object })
|
|
|
|
type alias MessageHandler m = String -> Value -> m -> m
|
|
|
|
handle_message : Dict String (Value -> m -> m) -> MessageHandler m
|
|
handle_message message_handlers kind value model =
|
|
let
|
|
handler = Dict.get kind message_handlers |> Maybe.withDefault (\_ -> identity)
|
|
in
|
|
handler value model
|
|
|
|
handle_exam_message : MessageHandler Model
|
|
handle_exam_message = handle_message <| Dict.fromList
|
|
[ ("showQuestion", \_ -> show_question)
|
|
, ("updateQuestionList", \_ -> update_question_list)
|
|
, ("question", \value model ->
|
|
let
|
|
mexam : Maybe Exam
|
|
mexam = model.exam
|
|
|
|
q = Debug.log "question message" minfo
|
|
|
|
minfo = value |> JD.decodeValue
|
|
(JD.map3 QuestionMessage
|
|
(JD.field "questionNumber" JD.int)
|
|
(JD.field "type" JD.string)
|
|
(JD.field "arg" JD.value)
|
|
)
|
|
|> Result.toMaybe
|
|
|
|
mquestion : Maybe Question
|
|
mquestion = Maybe.map2 get_question mexam (Maybe.map .questionNumber minfo) |> Maybe.andThen identity
|
|
in
|
|
case (minfo, mexam) of
|
|
(Just info, Just exam) -> map_question info.questionNumber (handle_question_message info.type_ info.msg) model
|
|
_ -> model
|
|
)
|
|
]
|
|
|
|
handle_question_message : MessageHandler Question
|
|
handle_question_message = handle_message <| Dict.fromList
|
|
[ ("isDirty", \v q ->
|
|
v |> JD.decodeValue (JD.bool) |> Result.map (\dirty -> {q | isDirty = dirty}) |> Result.withDefault q
|
|
)
|
|
, ("showScore", \_ q -> {q | score = JD.decodeValue (JD.field "score" JD.float) q.object |> Result.withDefault q.score })
|
|
, ("part", \value question ->
|
|
let
|
|
minfo = value |> JD.decodeValue
|
|
(JD.map3 PartMessage
|
|
(JD.field "partPath" JD.string)
|
|
(JD.field "type" JD.string)
|
|
(JD.field "arg" JD.value)
|
|
)
|
|
|> Result.toMaybe
|
|
|
|
q = Debug.log "part message" minfo
|
|
|
|
mpart = Maybe.map (.partPath >> get_part question) minfo
|
|
in
|
|
case (minfo, mpart) of
|
|
(Just info, Just part) -> map_part info.partPath (handle_part_message info.type_ info.msg) question
|
|
_ -> question
|
|
)
|
|
]
|
|
|
|
handle_part_message : MessageHandler Part
|
|
handle_part_message = handle_message <| Dict.fromList
|
|
[ ("showScore", \_ p ->
|
|
let
|
|
score = decode_default (JD.field "score" JD.float) 0 p.object
|
|
marks = decode_default (JD.field "marks" JD.float) 0 p.object
|
|
marking_feedback = decode_default (JD.field "markingFeedback" (JD.list decode_feedback_message)) [] p.object
|
|
in
|
|
{p | score = score, marks = marks, marking_feedback = marking_feedback })
|
|
]
|
|
|
|
subscriptions model =
|
|
Sub.batch
|
|
[ receiveMessage ReceiveMessage
|
|
]
|
|
|
|
get_exam_name : Exam -> String
|
|
get_exam_name = .object >> JD.decodeValue (JD.at ["settings","name"] JD.string) >> Result.withDefault "Unnamed exam"
|
|
|
|
get_questions : JE.Value -> List Question
|
|
get_questions = JD.decodeValue (JD.at ["questionList"] (JD.list decode_question)) >> Result.withDefault []
|
|
|
|
get_question : Exam -> Int -> Maybe Question
|
|
get_question exam n = listGet n exam.questions
|
|
|
|
get_part : Question -> String -> Maybe Part
|
|
get_part question path = question.parts |> List.filter (\p -> p.path == path) |> List.head
|
|
|
|
decode_question : JD.Decoder Question
|
|
decode_question =
|
|
JD.succeed Question
|
|
|> JDP.hardcoded False
|
|
|> JDP.hardcoded 0
|
|
|> JDP.custom JD.value
|
|
|> required "name" JD.string
|
|
|> requiredAt ["display", "allParts"] (JD.list decode_part)
|
|
|> required "number" JD.int
|
|
|> JDP.optionalAt ["display", "statement"] JD.value (JE.string "")
|
|
|
|
decode_part : JD.Decoder Part
|
|
decode_part =
|
|
JD.succeed Part
|
|
|> JDP.custom JD.value
|
|
|> required "name" JD.string
|
|
|> required "type" decode_part_type
|
|
|> required "path" JD.string
|
|
|> required "score" JD.float
|
|
|> required "marks" JD.float
|
|
|> JDP.optionalAt ["display", "prompt"] JD.value (JE.string "")
|
|
|> JDP.optional "markingFeedback" (JD.list decode_feedback_message) []
|
|
|> JDP.optional "gaps" (JD.map Gaps <| JD.list (JD.lazy (\_ -> decode_part))) (Gaps [])
|
|
|
|
part_types : Dict String PartType
|
|
part_types = Dict.fromList
|
|
[ ("information", InformationOnlyPart)
|
|
, ("numberentry", NumberEntryPart)
|
|
, ("jme", MathematicalExpressionPart)
|
|
, ("patternmatch", PatternMatchPart)
|
|
]
|
|
|
|
decode_part_type : JD.Decoder PartType
|
|
decode_part_type =
|
|
JD.string |> JD.map (\t -> Dict.get t part_types |> Maybe.withDefault (CustomPart t))
|
|
|
|
decode_feedback_message =
|
|
JD.succeed FeedbackMessage
|
|
|> required "op" JD.string
|
|
|> JDP.optional "credit" (JD.maybe JD.float) Nothing
|
|
|> required "message" JD.value
|
|
|> JDP.optional "reason" (JD.maybe JD.string) Nothing
|
|
|> JDP.optional "credit_change" (JD.maybe JD.string) Nothing
|
|
|
|
external_html : JE.Value -> Html Msg
|
|
external_html html =
|
|
H.node "elm-html"
|
|
[ HA.property "html" html ]
|
|
[]
|
|
|
|
format_score : Float -> Float -> String
|
|
format_score score marks = (String.fromFloat score)++"/"++(String.fromFloat marks)
|
|
|
|
view model = case model.exam of
|
|
Nothing -> view_loading
|
|
Just exam ->
|
|
case model.view_mode of
|
|
ViewWholeExam -> view_exam model exam
|
|
|
|
ViewQuestion n -> case get_question exam n of
|
|
Just question -> view_question question
|
|
Nothing -> H.text "That question doesn't exist"
|
|
|
|
ViewPart n path -> case get_question exam n |> Maybe.andThen (\q -> get_part q path |> Maybe.map (pair q)) of
|
|
Just (question, part) -> view_part question part
|
|
Nothing -> H.text "That part doesn't exist"
|
|
|
|
ViewPartAnswer n path -> case get_question exam n |> Maybe.andThen (\q -> get_part q path |> Maybe.map (pair q)) of
|
|
Just (question, part) -> view_part_answer_input question part
|
|
Nothing -> H.text <| "That part (q"++(String.fromInt n)++(path)++") doesn't exist"
|
|
|
|
view_loading = H.text "It's loading"
|
|
|
|
view_exam : Model -> Exam -> Html Msg
|
|
view_exam model exam =
|
|
let
|
|
exam_name = get_exam_name exam
|
|
questions = exam.questions
|
|
|
|
in
|
|
H.div
|
|
[]
|
|
[ H.h1 [] [H.text <| exam_name]
|
|
{-
|
|
, H.ul
|
|
[]
|
|
(List.map (\msg -> H.li [] [H.text msg]) (List.take 5 model.messages))
|
|
-}
|
|
, H.ul
|
|
[]
|
|
(List.map (\q -> H.li [] [view_question q]) questions)
|
|
]
|
|
|
|
view_question question =
|
|
H.div
|
|
[]
|
|
[ H.h2 [] [H.text question.name, H.text <| if question.isDirty then " (dirty)" else " (clean)"]
|
|
, H.p [] [H.text "Score: ", H.text <| String.fromFloat question.score]
|
|
, external_html question.statement
|
|
, H.ul
|
|
[]
|
|
(List.map (\p -> H.li [] [view_part question p]) question.parts)
|
|
]
|
|
|
|
view_part : Question -> Part -> Html Msg
|
|
view_part question part =
|
|
let
|
|
gaps = case part.gaps of
|
|
Gaps g -> g
|
|
in
|
|
H.div
|
|
[]
|
|
[ H.h3 [] [H.text part.name]
|
|
, H.p [] [H.text <| Debug.toString part.type_]
|
|
, H.p [] [H.text <| "Score: " ++ (format_score part.score part.marks)]
|
|
, external_html part.prompt
|
|
, view_part_answer_input question part
|
|
, H.ul
|
|
[]
|
|
(List.map (\f -> view_feedback_message f) part.marking_feedback)
|
|
]
|
|
|
|
view_part_answer_input question part =
|
|
let
|
|
msgs =
|
|
{ store_answer =
|
|
pair "answer"
|
|
>> List.singleton
|
|
>> SendPartMessage question part "part_answer"
|
|
|
|
, submit_answer = SendPartMessage question part "submit" []
|
|
}
|
|
in
|
|
case part.type_ of
|
|
GapFillPart -> H.text ""
|
|
InformationOnlyPart -> H.text ""
|
|
_ ->
|
|
H.form
|
|
[ HE.onSubmit msgs.submit_answer
|
|
, HA.attribute "part" "answer-input-form"
|
|
, HE.on "focusout" (JD.succeed msgs.submit_answer)
|
|
]
|
|
[ case part.type_ of
|
|
NumberEntryPart -> number_entry_input msgs
|
|
MathematicalExpressionPart -> mathematical_expression_input msgs
|
|
_ -> H.text ""
|
|
]
|
|
|
|
type alias AnswerMessages =
|
|
{ store_answer : JE.Value -> Msg
|
|
, submit_answer : Msg
|
|
}
|
|
|
|
type alias AnswerInput = AnswerMessages -> Html Msg
|
|
|
|
number_entry_input : AnswerInput
|
|
number_entry_input msgs =
|
|
H.input
|
|
[ HE.onInput (
|
|
JE.string
|
|
>> msgs.store_answer
|
|
)
|
|
]
|
|
[]
|
|
|
|
mathematical_expression_input : AnswerInput
|
|
mathematical_expression_input msgs =
|
|
H.input
|
|
[ HE.onInput (
|
|
JE.string
|
|
>> msgs.store_answer
|
|
)
|
|
]
|
|
[]
|
|
|
|
view_feedback_message f =
|
|
let
|
|
feedback_icon = case f.credit_change of
|
|
Just "positive" -> H.text "+"
|
|
Just "negative" -> H.text "-"
|
|
_ -> H.text ""
|
|
in
|
|
H.li
|
|
[HA.class "feedback-message"]
|
|
[ feedback_icon
|
|
, external_html f.message
|
|
] |