summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Tonkadur/Json.elm403
1 files changed, 403 insertions, 0 deletions
diff --git a/src/Tonkadur/Json.elm b/src/Tonkadur/Json.elm
new file mode 100644
index 0000000..3860548
--- /dev/null
+++ b/src/Tonkadur/Json.elm
@@ -0,0 +1,403 @@
+module Tonkadur.Json exposing (decoder)
+
+-- Elm -------------------------------------------------------------------------
+import Array
+import Dict
+import List
+import Random
+
+import Json.Decode
+import Json.Decode.Pipeline
+
+-- Tonkadur --------------------------------------------------------------------
+import Tonkadur.Types
+
+--------------------------------------------------------------------------------
+-- TYPES -----------------------------------------------------------------------
+--------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+-- LOCAL -----------------------------------------------------------------------
+--------------------------------------------------------------------------------
+---- COMPUTATIONS --------------------------------------------------------------
+specific_computation_decoder : (
+ String ->
+ (Json.Decode.Decoder Tonkadur.Types.Computation)
+ )
+specific_computation_decoder name =
+ case name of
+ "add_text_effect" ->
+ (Json.Decode.map3
+ (\ename params content ->
+ (Tonkadur.Types.AddTextEffect ename params content)
+ )
+ (Json.Decode.field "effect" (Json.Decode.string))
+ (Json.Decode.field
+ "parameters"
+ (Json.Decode.list (computation_decoder))
+ )
+ (Json.Decode.field
+ "content"
+ (Json.Decode.list (computation_decoder))
+ )
+ )
+
+ "address" ->
+ (Json.Decode.map
+ (\address -> (Tonkadur.Types.Address address))
+ (Json.Decode.field "address" (computation_decoder))
+ )
+
+ "cast" ->
+ (Json.Decode.map3
+ (\from to value -> (Tonkadur.Types.Cast from to value))
+ (Json.Decode.field "from" (Json.Decode.string))
+ (Json.Decode.field "to" (Json.Decode.string))
+ (Json.Decode.field "content" (computation_decoder))
+ )
+
+ "constant" ->
+ (Json.Decode.map2
+ (\type_name value -> (Tonkadur.Types.Constant type_name value))
+ (Json.Decode.field "type" (Json.Decode.string))
+ (Json.Decode.field "value" (Json.Decode.string))
+ )
+
+ "get_allocable_address" ->
+ (Json.Decode.succeed Tonkadur.Types.NextAllocableAddress)
+
+ "if_else" ->
+ (Json.Decode.map3
+ (\condition if_true if_false ->
+ (Tonkadur.Types.IfElse condition if_true if_false)
+ )
+ (Json.Decode.field "condition" (computation_decoder))
+ (Json.Decode.field "if_true" (computation_decoder))
+ (Json.Decode.field "if_false" (computation_decoder))
+ )
+
+ "last_choice_index" ->
+ (Json.Decode.succeed Tonkadur.Types.LastChoiceIndex)
+
+ "newline" -> (Json.Decode.succeed Tonkadur.Types.Newline)
+ "operation" ->
+ (Json.Decode.map3
+ (\op x maybe_y ->
+ (Tonkadur.Types.Operation
+ op
+ x
+ (
+ case maybe_y of
+ (Just y) -> y
+ Nothing ->
+ (Tonkadur.Types.Constant
+ "string"
+ "No second operand provided."
+ )
+ )
+ )
+ )
+ (Json.Decode.field "operator" (Json.Decode.string))
+ (Json.Decode.field "x" (computation_decoder))
+ (Json.Decode.maybe (Json.Decode.field "y" (computation_decoder)))
+ )
+
+ "relative_address" ->
+ (Json.Decode.map2
+ (\base extra -> (Tonkadur.Types.RelativeAddress base extra))
+ (Json.Decode.field "base" (computation_decoder))
+ (Json.Decode.field "extra" (computation_decoder))
+ )
+
+ "text" ->
+ (Json.Decode.map
+ (\computation -> (Tonkadur.Types.Text computation))
+ (Json.Decode.field
+ "content"
+ (Json.Decode.list (computation_decoder))
+ )
+ )
+
+ "value_of" ->
+ (Json.Decode.map
+ (\computation -> (Tonkadur.Types.ValueOf computation))
+ (Json.Decode.field "reference" (computation_decoder))
+ )
+
+ _ ->
+ (Json.Decode.map
+ (\params -> (Tonkadur.Types.ExtraComputation name params))
+ (Json.Decode.field "params"
+ (Json.Decode.list (computation_decoder))
+ )
+ )
+
+computation_decoder : (Json.Decode.Decoder Tonkadur.Types.Computation)
+computation_decoder =
+ (Json.Decode.andThen
+ (specific_computation_decoder)
+ (Json.Decode.field "category" (Json.Decode.string))
+ )
+
+---- INSTRUCTIONS --------------------------------------------------------------
+prompt_instruction_data_decoder : (
+ (Json.Decode.Decoder Tonkadur.Types.PromptInstructionData)
+ )
+prompt_instruction_data_decoder =
+ (Json.Decode.succeed
+ Tonkadur.Types.PromptInstructionData
+ -- min
+ |> (Json.Decode.Pipeline.required "min" (computation_decoder))
+
+ -- max
+ |> (Json.Decode.Pipeline.required "max" (computation_decoder))
+
+ -- address
+ |> (Json.Decode.Pipeline.required "target" (computation_decoder))
+
+ -- label
+ |> (Json.Decode.Pipeline.required "label" (computation_decoder))
+ )
+
+specific_instruction_decoder : (
+ String -> (Json.Decode.Decoder Tonkadur.Types.Instruction)
+ )
+specific_instruction_decoder name =
+ case name of
+ "add_event_option" ->
+ (Json.Decode.map2
+ (\oname params -> (Tonkadur.Types.AddEventOption oname params))
+ (Json.Decode.field "event" (Json.Decode.string))
+ (Json.Decode.field
+ "reference"
+ (Json.Decode.list (computation_decoder))
+ )
+ )
+
+ "add_text_option" ->
+ (Json.Decode.map
+ (\computation -> (Tonkadur.Types.AddTextOption computation))
+ (Json.Decode.field "label" (computation_decoder))
+ )
+
+ "assert" ->
+ (Json.Decode.map2
+ (\condition label -> (Tonkadur.Types.Assert condition label))
+ (Json.Decode.field "condition" (computation_decoder))
+ (Json.Decode.field "message" (computation_decoder))
+ )
+
+ "display" ->
+ (Json.Decode.map
+ (\computation -> (Tonkadur.Types.Display computation))
+ (Json.Decode.field "content" (computation_decoder))
+ )
+
+ "end" -> (Json.Decode.succeed Tonkadur.Types.End)
+ "initialize" ->
+ (Json.Decode.map2
+ (\type_name ref -> (Tonkadur.Types.Initialize type_name ref))
+ (Json.Decode.field "type" (Json.Decode.string))
+ (Json.Decode.field "reference" (computation_decoder))
+ )
+
+ "prompt_command" ->
+ (Json.Decode.map
+ (\data -> (Tonkadur.Types.PromptCommand data))
+ (prompt_instruction_data_decoder)
+ )
+
+ "prompt_integer" ->
+ (Json.Decode.map
+ (\data -> (Tonkadur.Types.PromptInteger data))
+ (prompt_instruction_data_decoder)
+ )
+
+ "prompt_string" ->
+ (Json.Decode.map
+ (\data -> (Tonkadur.Types.PromptString data))
+ (prompt_instruction_data_decoder)
+ )
+
+ "remove" ->
+ (Json.Decode.map
+ (\computation -> (Tonkadur.Types.Remove computation))
+ (Json.Decode.field "reference" (computation_decoder))
+ )
+
+ "resolve_choice" -> (Json.Decode.succeed Tonkadur.Types.ResolveChoice)
+ "set_pc" ->
+ (Json.Decode.map
+ (\computation -> (Tonkadur.Types.SetPC computation))
+ (Json.Decode.field "value" (computation_decoder))
+ )
+
+ "set_random" ->
+ (Json.Decode.map3
+ (\min max target -> (Tonkadur.Types.SetRandom min max target))
+ (Json.Decode.field "min" (computation_decoder))
+ (Json.Decode.field "max" (computation_decoder))
+ (Json.Decode.field "target" (computation_decoder))
+ )
+
+ "set_value" ->
+ (Json.Decode.map2
+ (\target value -> (Tonkadur.Types.Set target value))
+ (Json.Decode.field "reference" (computation_decoder))
+ (Json.Decode.field "value" (computation_decoder))
+ )
+
+ _ ->
+ (Json.Decode.map
+ (\params -> (Tonkadur.Types.ExtraInstruction name params))
+ (Json.Decode.field "params"
+ (Json.Decode.list (computation_decoder))
+ )
+ )
+
+instruction_decoder : (Json.Decode.Decoder Tonkadur.Types.Instruction)
+instruction_decoder =
+ (Json.Decode.andThen
+ (specific_instruction_decoder)
+ (Json.Decode.field "category" (Json.Decode.string))
+ )
+
+
+---- TYPES --------------------------------------------------------------------
+-- There's a slight issue: we're getting the type definitions before they're
+-- used, yes, but we're getting all the type definitions before we're able to
+-- use the previous results.
+-- To mitigate this issue, we first get type names for fields instead of values
+-- (the 'raw' decoder), then we generate the actual values.
+raw_user_type_decoder : (
+ (Json.Decode.Decoder (String, (Dict.Dict String String)))
+ )
+raw_user_type_decoder =
+ (Json.Decode.map2
+ (\name pair_list -> (name, (Dict.fromList pair_list)))
+ (Json.Decode.field "name" (Json.Decode.string))
+ (Json.Decode.field "fields"
+ (Json.Decode.list
+ (Json.Decode.map2
+ (\name line -> (name, line))
+ (Json.Decode.field "name" (Json.Decode.string))
+ (Json.Decode.field "type" (Json.Decode.string))
+ )
+ )
+ )
+ )
+
+user_types_decoder : (
+ (Json.Decode.Decoder (Dict.Dict String Tonkadur.Types.Value))
+ )
+user_types_decoder =
+ (Json.Decode.map
+ (\list_of_raw_types ->
+ (List.foldl
+ (\(name, fields) defined_types ->
+ (Dict.insert
+ name
+ (Tonkadur.Types.StructureValue
+ (Dict.map
+ (\field_name field_type_name ->
+ case
+ (Tonkadur.Types.maybe_get_default_primitive
+ field_type_name
+ )
+ of
+ (Just default) -> default
+ Nothing ->
+ case
+ (Dict.get field_type_name defined_types)
+ of
+ (Just default) -> default
+ Nothing ->
+ (Tonkadur.Types.StringValue
+ (
+ "Undefined type '"
+ ++ field_type_name
+ ++ "'"
+ )
+ )
+ )
+ fields
+ )
+ )
+ defined_types
+ )
+ )
+ (Dict.empty)
+ list_of_raw_types
+ )
+ )
+ (Json.Decode.list (raw_user_type_decoder))
+ )
+
+---- STATE ---------------------------------------------------------------------
+code_decoder : (Json.Decode.Decoder (Array.Array Tonkadur.Types.Instruction))
+code_decoder = (Json.Decode.array (instruction_decoder))
+
+sequences_decoder : (Json.Decode.Decoder (Dict.Dict String Int))
+sequences_decoder =
+ (Json.Decode.map
+ (\pair_list -> (Dict.fromList pair_list))
+ (Json.Decode.list
+ (Json.Decode.map2
+ (\name line -> (name, line))
+ (Json.Decode.field "name" (Json.Decode.string))
+ (Json.Decode.field "value" (Json.Decode.int))
+ )
+ )
+ )
+
+--------------------------------------------------------------------------------
+-- EXPORTED --------------------------------------------------------------------
+--------------------------------------------------------------------------------
+decoder : (Json.Decode.Decoder Tonkadur.Types.State)
+decoder =
+ (Json.Decode.succeed
+ Tonkadur.Types.State
+ -- memory
+ |> (Json.Decode.Pipeline.hardcoded (Dict.empty))
+
+ -- user_types
+ |> (Json.Decode.Pipeline.optional
+ "structure_types"
+ (user_types_decoder)
+ (Dict.empty)
+ )
+
+ -- sequences
+ |> (Json.Decode.Pipeline.optional
+ "sequences"
+ (sequences_decoder)
+ (Dict.empty)
+ )
+
+ -- code
+ |> (Json.Decode.Pipeline.required "code" (code_decoder))
+
+ -- program_counter
+ |> (Json.Decode.Pipeline.hardcoded 0)
+
+ -- allocated_data
+ |> (Json.Decode.Pipeline.hardcoded 0)
+
+ -- last_choice_index
+ |> (Json.Decode.Pipeline.hardcoded 0)
+
+ -- available_options
+ |> (Json.Decode.Pipeline.hardcoded [])
+
+ -- memorized_target
+ |> (Json.Decode.Pipeline.hardcoded (Tonkadur.Types.PointerValue []))
+
+ -- last_instruction_effect
+ |> (Json.Decode.Pipeline.hardcoded Tonkadur.Types.MustContinue)
+
+ -- freed_addresses
+ |> (Json.Decode.Pipeline.hardcoded [])
+
+ -- random_seed
+ |> (Json.Decode.Pipeline.hardcoded (Random.initialSeed 42))
+ )