sforman
/
Thun
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Format.

This commit is contained in:
sforman 2023-07-30 07:47:26 -07:00
parent 9963a73322
commit 64d9bb75a4
1 changed files with 541 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

629
implementations/Elm/src/Joy.elm
View File

@ -1,9 +1,9 @@
module Joy exposing (doit, JoyDict, initialize) module Joy exposing (JoyDict, doit, initialize)
import Bitwise import Bitwise
import Dict exposing (Dict, get, insert) import Dict exposing (Dict, get, insert)
import Result exposing (andThen) import Result exposing (andThen)
import String exposing (replace, words, lines) import String exposing (lines, replace, words)
type JoyType type JoyType
@ -13,9 +13,13 @@ type JoyType
| JoyTrue | JoyTrue
| JoyFalse | JoyFalse
type alias JList = List JoyType
type alias JoyDict = Dict String JList type alias JList =
List JoyType
type alias JoyDict =
Dict String JList
joy : JList -> JList -> JoyDict -> Result String ( JList, JoyDict ) joy : JList -> JList -> JoyDict -> Result String ( JList, JoyDict )
@ -23,12 +27,17 @@ joy stack expression dict =
case expression of case expression of
[] -> [] ->
Ok ( stack, dict ) Ok ( stack, dict )
term :: rest_of_expression -> term :: rest_of_expression ->
case term of case term of
JoySymbol symbol -> JoySymbol symbol ->
case joy_eval symbol stack rest_of_expression dict of case joy_eval symbol stack rest_of_expression dict of
Err msg -> Err msg Err msg ->
Ok (s, e, dict0) -> joy s e dict0 Err msg
Ok ( s, e, dict0 ) ->
joy s e dict0
_ -> _ ->
joy (term :: stack) rest_of_expression dict joy (term :: stack) rest_of_expression dict
@ -37,8 +46,10 @@ joy_eval : String -> JList -> JList -> JoyDict -> Result String (JList, JList, J
joy_eval symbol stack expression dict = joy_eval symbol stack expression dict =
if symbol == "" then if symbol == "" then
Ok ( stack, expression, dict ) Ok ( stack, expression, dict )
else if symbol == "inscribe" then else if symbol == "inscribe" then
joy_inscribe stack expression dict joy_inscribe stack expression dict
else else
case joy_function_eval symbol stack expression of case joy_function_eval symbol stack expression of
Err msg -> Err msg ->
@ -47,301 +58,470 @@ joy_eval symbol stack expression dict =
case get symbol dict of case get symbol dict of
Just definition -> Just definition ->
Ok ( stack, definition ++ expression, dict ) Ok ( stack, definition ++ expression, dict )
Nothing -> Nothing ->
Err ("Unknown word: " ++ symbol) Err ("Unknown word: " ++ symbol)
else else
Err msg Err msg
Ok (stack0, expression0) -> Ok (stack0, expression0, dict)
Ok ( stack0, expression0 ) ->
Ok ( stack0, expression0, dict )
joy_function_eval symbol stack expression = joy_function_eval symbol stack expression =
case symbol of case symbol of
"branch" ->
joy_branch stack expression
"branch" -> joy_branch stack expression "i" ->
"i" -> joy_i stack expression joy_i stack expression
"dip" -> joy_dip stack expression
"loop" -> joy_loop stack expression
"+" -> joy_binary_math_op (+) stack expression "dip" ->
"-" -> joy_binary_math_op (-) stack expression joy_dip stack expression
"*" -> joy_binary_math_op (*) stack expression
"/" -> joy_binary_math_op (//) stack expression
"%" -> joy_binary_math_op (swap_args remainderBy) stack expression
"add" -> joy_binary_math_op (+) stack expression "loop" ->
"sub" -> joy_binary_math_op (-) stack expression joy_loop stack expression
"mul" -> joy_binary_math_op (*) stack expression
"div" -> joy_binary_math_op (//) stack expression
"mod" -> joy_binary_math_op (swap_args remainderBy) stack expression
"<" -> joy_comparison_op (<) stack expression "+" ->
">" -> joy_comparison_op (>) stack expression joy_binary_math_op (+) stack expression
"<=" -> joy_comparison_op (<=) stack expression
">=" -> joy_comparison_op (>=) stack expression
"<>" -> joy_comparison_op (/=) stack expression
"!=" -> joy_comparison_op (/=) stack expression
"=" -> joy_comparison_op (==) stack expression
"and" -> joy_binary_math_op (Bitwise.and) stack expression "-" ->
"or" -> joy_binary_math_op (Bitwise.or) stack expression joy_binary_math_op (-) stack expression
"xor" -> joy_binary_math_op (Bitwise.xor) stack expression
"lshift" -> joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"<<" -> joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"rshift" -> joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
">>" -> joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
"/\\" -> joy_logical_op (&&) stack expression "*" ->
"\\/" -> joy_logical_op (||) stack expression joy_binary_math_op (*) stack expression
"_\\/_" -> joy_logical_op (xor) stack expression
"clear" -> Ok ([], expression) "/" ->
"concat" -> joy_concat stack expression joy_binary_math_op (//) stack expression
"cons" -> joy_cons stack expression
"dup" -> joy_dup stack expression
"first" -> joy_first stack expression
"pop" -> joy_pop stack expression
"rest" -> joy_rest stack expression
"stack" -> joy_stack stack expression
"swaack" -> joy_swaack stack expression
"swap" -> joy_swap stack expression
"truthy" -> joy_truthy stack expression
"bool" -> joy_truthy stack expression
_ -> Err ("Unknown word.") "%" ->
joy_binary_math_op (swap_args remainderBy) stack expression
"add" ->
joy_binary_math_op (+) stack expression
"sub" ->
joy_binary_math_op (-) stack expression
"mul" ->
joy_binary_math_op (*) stack expression
"div" ->
joy_binary_math_op (//) stack expression
"mod" ->
joy_binary_math_op (swap_args remainderBy) stack expression
"<" ->
joy_comparison_op (<) stack expression
">" ->
joy_comparison_op (>) stack expression
"<=" ->
joy_comparison_op (<=) stack expression
">=" ->
joy_comparison_op (>=) stack expression
"<>" ->
joy_comparison_op (/=) stack expression
"!=" ->
joy_comparison_op (/=) stack expression
"=" ->
joy_comparison_op (==) stack expression
"and" ->
joy_binary_math_op Bitwise.and stack expression
"or" ->
joy_binary_math_op Bitwise.or stack expression
"xor" ->
joy_binary_math_op Bitwise.xor stack expression
"lshift" ->
joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"<<" ->
joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"rshift" ->
joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
">>" ->
joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
"/\\" ->
joy_logical_op (&&) stack expression
"\\/" ->
joy_logical_op (||) stack expression
"_\\/_" ->
joy_logical_op xor stack expression
"clear" ->
Ok ( [], expression )
"concat" ->
joy_concat stack expression
"cons" ->
joy_cons stack expression
"dup" ->
joy_dup stack expression
"first" ->
joy_first stack expression
"pop" ->
joy_pop stack expression
"rest" ->
joy_rest stack expression
"stack" ->
joy_stack stack expression
"swaack" ->
joy_swaack stack expression
"swap" ->
joy_swap stack expression
"truthy" ->
joy_truthy stack expression
"bool" ->
joy_truthy stack expression
_ ->
Err "Unknown word."
joy_inscribe : JList -> JList -> JoyDict -> Result String ( JList, JList, JoyDict ) joy_inscribe : JList -> JList -> JoyDict -> Result String ( JList, JList, JoyDict )
joy_inscribe stack expression dict = joy_inscribe stack expression dict =
case pop_list(stack) of case pop_list stack of
Ok ( def, s0 ) -> Ok ( def, s0 ) ->
case def of case def of
[] -> Err "Empty definition." [] ->
Err "Empty definition."
sym :: body -> sym :: body ->
-- check that name is a symbol -- check that name is a symbol
case sym of case sym of
JoySymbol name -> JoySymbol name ->
Ok (s0, expression, (insert name body dict)) Ok ( s0, expression, insert name body dict )
_ -> _ ->
Err "Def name isn't symbol." Err "Def name isn't symbol."
Err msg -> Err msg
Err msg ->
Err msg
joy_branch : JList -> JList -> Result String ( JList, JList ) joy_branch : JList -> JList -> Result String ( JList, JList )
joy_branch stack expression = joy_branch stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( true_body, s0 ) -> Ok ( true_body, s0 ) ->
case pop_list(s0) of case pop_list s0 of
Ok ( false_body, s1 ) -> Ok ( false_body, s1 ) ->
case pop_bool(s1) of case pop_bool s1 of
Ok ( flag, s2 ) -> Ok ( flag, s2 ) ->
if flag then if flag then
Ok ( s2, true_body ++ expression ) Ok ( s2, true_body ++ expression )
else else
Ok ( s2, false_body ++ expression ) Ok ( s2, false_body ++ expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg -> Err msg Err msg
Err msg ->
Err msg
Err msg ->
Err msg
joy_i : JList -> JList -> Result String ( JList, JList ) joy_i : JList -> JList -> Result String ( JList, JList )
joy_i stack expression = joy_i stack expression =
case pop_list(stack) of case pop_list stack of
Ok (a, s0) -> Ok (s0, a ++ expression) Ok ( a, s0 ) ->
Err msg -> Err msg Ok ( s0, a ++ expression )
Err msg ->
Err msg
joy_dip : JList -> JList -> Result String ( JList, JList ) joy_dip : JList -> JList -> Result String ( JList, JList )
joy_dip stack expression = joy_dip stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( quoted_expression, s0 ) -> Ok ( quoted_expression, s0 ) ->
case pop_any(s0) of case pop_any s0 of
Ok (x, s1) -> Ok (s1, quoted_expression ++ (x :: expression)) Ok ( x, s1 ) ->
Err msg -> Err msg Ok ( s1, quoted_expression ++ (x :: expression) )
Err msg -> Err msg
Err msg ->
Err msg
Err msg ->
Err msg
joy_loop : JList -> JList -> Result String ( JList, JList ) joy_loop : JList -> JList -> Result String ( JList, JList )
joy_loop stack expression = joy_loop stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( loop_body, s0 ) -> Ok ( loop_body, s0 ) ->
case pop_bool(s0) of case pop_bool s0 of
Ok ( flag, s1 ) -> Ok ( flag, s1 ) ->
if flag then if flag then
Ok (s1, loop_body ++ ((JoyList loop_body) :: (JoySymbol "loop") :: expression)) Ok ( s1, loop_body ++ (JoyList loop_body :: JoySymbol "loop" :: expression) )
else else
Ok ( s1, expression ) Ok ( s1, expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg
Err msg ->
Err msg
joy_binary_math_op : (Int -> Int -> Int) -> JList -> JList -> Result String ( JList, JList ) joy_binary_math_op : (Int -> Int -> Int) -> JList -> JList -> Result String ( JList, JList )
joy_binary_math_op op stack expression = joy_binary_math_op op stack expression =
case pop_int(stack) of case pop_int stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_int(s0) of case pop_int s0 of
Ok ( b, s1 ) -> Ok ( b, s1 ) ->
Ok ((push_int (op b a) s1), expression) Ok ( push_int (op b a) s1, expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg
Err msg ->
Err msg
swap_args : (Int -> Int -> Int) -> (Int -> Int -> Int) swap_args : (Int -> Int -> Int) -> (Int -> Int -> Int)
swap_args op = (\a b -> op b a) swap_args op =
\a b -> op b a
joy_comparison_op : (Int -> Int -> Bool) -> JList -> JList -> Result String ( JList, JList ) joy_comparison_op : (Int -> Int -> Bool) -> JList -> JList -> Result String ( JList, JList )
joy_comparison_op op stack expression = joy_comparison_op op stack expression =
case pop_int(stack) of case pop_int stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_int(s0) of case pop_int s0 of
Ok ( b, s1 ) -> Ok ( b, s1 ) ->
Ok ((push_bool (op b a) s1), expression) Ok ( push_bool (op b a) s1, expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg
Err msg ->
Err msg
joy_logical_op : (Bool -> Bool -> Bool) -> JList -> JList -> Result String ( JList, JList ) joy_logical_op : (Bool -> Bool -> Bool) -> JList -> JList -> Result String ( JList, JList )
joy_logical_op op stack expression = joy_logical_op op stack expression =
case pop_bool(stack) of case pop_bool stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_bool(s0) of case pop_bool s0 of
Ok ( b, s1 ) -> Ok ( b, s1 ) ->
Ok ((push_bool (op b a) s1), expression) Ok ( push_bool (op b a) s1, expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg
Err msg ->
Err msg
joy_concat : JList -> JList -> Result String ( JList, JList ) joy_concat : JList -> JList -> Result String ( JList, JList )
joy_concat stack expression = joy_concat stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_list(s0) of case pop_list s0 of
Ok ( b, s1 ) -> Ok ( b, s1 ) ->
Ok ((push_list (b ++ a) s1), expression) Ok ( push_list (b ++ a) s1, expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg
Err msg ->
Err msg
joy_cons : JList -> JList -> Result String ( JList, JList ) joy_cons : JList -> JList -> Result String ( JList, JList )
joy_cons stack expression = joy_cons stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_any(s0) of case pop_any s0 of
Ok ( b, s1 ) -> Ok ( b, s1 ) ->
Ok ((push_list (b :: a) s1), expression) Ok ( push_list (b :: a) s1, expression )
Err msg -> Err msg
Err msg -> Err msg Err msg ->
Err msg
Err msg ->
Err msg
joy_dup : JList -> JList -> Result String ( JList, JList ) joy_dup : JList -> JList -> Result String ( JList, JList )
joy_dup stack expression = joy_dup stack expression =
case pop_any(stack) of case pop_any stack of
Ok (a, s0) -> Ok ((a :: stack), expression) Ok ( a, s0 ) ->
Err msg -> Err msg Ok ( a :: stack, expression )
Err msg ->
Err msg
joy_first : JList -> JList -> Result String ( JList, JList ) joy_first : JList -> JList -> Result String ( JList, JList )
joy_first stack expression = joy_first stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_any(a) of case pop_any a of
Ok (b, _) -> Ok ((push_any b s0), expression) Ok ( b, _ ) ->
Err _ -> Err "Cannot take first of empty list." Ok ( push_any b s0, expression )
Err msg -> Err msg
Err _ ->
Err "Cannot take first of empty list."
Err msg ->
Err msg
joy_pop : JList -> JList -> Result String ( JList, JList ) joy_pop : JList -> JList -> Result String ( JList, JList )
joy_pop stack expression = joy_pop stack expression =
case pop_any(stack) of case pop_any stack of
Ok (_, s0) -> Ok (s0, expression) Ok ( _, s0 ) ->
Err msg -> Err msg Ok ( s0, expression )
Err msg ->
Err msg
joy_rest : JList -> JList -> Result String ( JList, JList ) joy_rest : JList -> JList -> Result String ( JList, JList )
joy_rest stack expression = joy_rest stack expression =
case pop_list(stack) of case pop_list stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_any(a) of case pop_any a of
Ok (_, el) -> Ok ((push_list el s0), expression) Ok ( _, el ) ->
Err _ -> Err "Cannot take rest of empty list." Ok ( push_list el s0, expression )
Err msg -> Err msg
Err _ ->
Err "Cannot take rest of empty list."
Err msg ->
Err msg
joy_stack : JList -> JList -> Result String ( JList, JList ) joy_stack : JList -> JList -> Result String ( JList, JList )
joy_stack stack expression = joy_stack stack expression =
Ok ((push_list stack stack), expression) Ok ( push_list stack stack, expression )
joy_swaack : JList -> JList -> Result String ( JList, JList ) joy_swaack : JList -> JList -> Result String ( JList, JList )
joy_swaack stack expression = joy_swaack stack expression =
case pop_list(stack) of case pop_list stack of
Ok (s, s0) -> Ok ((push_list s0 s), expression) Ok ( s, s0 ) ->
Err msg -> Err msg Ok ( push_list s0 s, expression )
Err msg ->
Err msg
joy_swap : JList -> JList -> Result String ( JList, JList ) joy_swap : JList -> JList -> Result String ( JList, JList )
joy_swap stack expression = joy_swap stack expression =
case pop_any(stack) of case pop_any stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case pop_any(s0) of case pop_any s0 of
Ok (b, s1) -> Ok ((b :: a :: s1), expression) Ok ( b, s1 ) ->
Err msg -> Err msg Ok ( b :: a :: s1, expression )
Err msg -> Err msg
Err msg ->
Err msg
Err msg ->
Err msg
joy_truthy : JList -> JList -> Result String ( JList, JList ) joy_truthy : JList -> JList -> Result String ( JList, JList )
joy_truthy stack expression = joy_truthy stack expression =
case pop_any(stack) of case pop_any stack of
Ok ( a, s0 ) -> Ok ( a, s0 ) ->
case a of case a of
JoyTrue -> Ok (stack, expression) JoyTrue ->
JoyFalse -> Ok (stack, expression) Ok ( stack, expression )
JoyFalse ->
Ok ( stack, expression )
JoyInt i -> JoyInt i ->
if 0 == i then if 0 == i then
Ok ( JoyFalse :: s0, expression ) Ok ( JoyFalse :: s0, expression )
else else
Ok ( JoyTrue :: s0, expression ) Ok ( JoyTrue :: s0, expression )
JoyList el -> JoyList el ->
if [] == el then if [] == el then
Ok ( JoyFalse :: s0, expression ) Ok ( JoyFalse :: s0, expression )
else else
Ok ( JoyTrue :: s0, expression ) Ok ( JoyTrue :: s0, expression )
JoySymbol _ -> JoySymbol _ ->
Err "Cannot Boolify." Err "Cannot Boolify."
Err msg -> Err msg
Err msg ->
Err msg
push_bool : Bool -> JList -> JList push_bool : Bool -> JList -> JList
push_bool flag stack = push_bool flag stack =
if flag then if flag then
JoyTrue :: stack JoyTrue :: stack
else else
JoyFalse :: stack JoyFalse :: stack
push_int : Int -> JList -> JList push_int : Int -> JList -> JList
push_int i stack = (JoyInt i) :: stack push_int i stack =
JoyInt i :: stack
push_list : JList -> JList -> JList push_list : JList -> JList -> JList
push_list el stack = (JoyList el) :: stack push_list el stack =
JoyList el :: stack
push_any : JoyType -> JList -> JList push_any : JoyType -> JList -> JList
push_any j stack = j :: stack push_any j stack =
j :: stack
pop_int : JList -> Result String ( Int, JList ) pop_int : JList -> Result String ( Int, JList )
pop_int stack = pop_any stack |> andThen isnt_int pop_int stack =
pop_any stack |> andThen isnt_int
pop_list : JList -> Result String ( JList, JList ) pop_list : JList -> Result String ( JList, JList )
pop_list stack = pop_any stack |> andThen isnt_list pop_list stack =
pop_any stack |> andThen isnt_list
pop_bool : JList -> Result String ( Bool, JList ) pop_bool : JList -> Result String ( Bool, JList )
pop_bool stack = pop_any stack |> andThen isnt_bool pop_bool stack =
pop_any stack |> andThen isnt_bool
pop_any : JList -> Result String ( JoyType, JList ) pop_any : JList -> Result String ( JoyType, JList )
@ -349,6 +529,7 @@ pop_any stack =
case stack of case stack of
[] -> [] ->
Err "Not enough values on Stack" Err "Not enough values on Stack"
item :: rest -> item :: rest ->
Ok ( item, rest ) Ok ( item, rest )
@ -358,6 +539,7 @@ isnt_int (item, stack) =
case item of case item of
JoyInt i -> JoyInt i ->
Ok ( i, stack ) Ok ( i, stack )
_ -> _ ->
Err "Not an integer." Err "Not an integer."
@ -367,6 +549,7 @@ isnt_list (item, stack) =
case item of case item of
JoyList el -> JoyList el ->
Ok ( el, stack ) Ok ( el, stack )
_ -> _ ->
Err "Not a list." Err "Not a list."
@ -374,101 +557,163 @@ isnt_list (item, stack) =
isnt_bool : ( JoyType, JList ) -> Result String ( Bool, JList ) isnt_bool : ( JoyType, JList ) -> Result String ( Bool, JList )
isnt_bool ( item, stack ) = isnt_bool ( item, stack ) =
case item of case item of
JoyTrue -> Ok (True, stack) JoyTrue ->
JoyFalse -> Ok (False, stack) Ok ( True, stack )
_ -> Err "Not a Boolean value."
JoyFalse ->
Ok ( False, stack )
_ ->
Err "Not a Boolean value."
-- Printer -- Printer
joyTermToString : JoyType -> String joyTermToString : JoyType -> String
joyTermToString term = joyTermToString term =
case term of case term of
JoySymbol name -> name JoySymbol name ->
JoyInt n -> String.fromInt n name
JoyTrue -> "true"
JoyFalse -> "false" JoyInt n ->
JoyList list -> String.fromInt n
"[" ++ (joyExpressionToString list) ++ "]"
JoyTrue ->
"true"
JoyFalse ->
"false"
JoyList list ->
"[" ++ joyExpressionToString list ++ "]"
joyExpressionToString expr =
String.join " " (List.map joyTermToString expr)
joyExpressionToString expr = String.join " " (List.map joyTermToString expr)
-- Use the old S-expression lexing trick. -- Use the old S-expression lexing trick.
tokenize : String -> (List String)
tokenize text = words (replace "[" " [ " (replace "]" " ] " text)) tokenize : String -> List String
tokenize text =
words (replace "[" " [ " (replace "]" " ] " text))
tokenator : String -> JoyType tokenator : String -> JoyType
tokenator tok = tokenator tok =
case tok of case tok of
"true" -> JoyTrue "true" ->
"false" -> JoyFalse JoyTrue
_ -> case String.toInt tok of
Just i -> JoyInt i "false" ->
Nothing -> JoySymbol tok JoyFalse
_ ->
case String.toInt tok of
Just i ->
JoyInt i
Nothing ->
JoySymbol tok
-- I don't like this because it won't reject "[" and "]" -- I don't like this because it won't reject "[" and "]"
-- instead turning them into symbols! -- instead turning them into symbols!
expect_right_bracket : List String -> JList -> Result String ( JList, List String )
expect_right_bracket : (List String) -> JList -> Result String (JList, List String)
expect_right_bracket tokens acc = expect_right_bracket tokens acc =
case tokens of case tokens of
[] -> Err "Missing closing bracket." [] ->
h :: t -> expect_right_bracket_one_token_lookahead h t acc Err "Missing closing bracket."
h :: t ->
expect_right_bracket_one_token_lookahead h t acc
expect_right_bracket_one_token_lookahead : String -> (List String) -> JList -> Result String (JList, List String) expect_right_bracket_one_token_lookahead : String -> List String -> JList -> Result String ( JList, List String )
expect_right_bracket_one_token_lookahead token tokens acc = expect_right_bracket_one_token_lookahead token tokens acc =
case token of case token of
"]" -> Ok (acc, tokens) "]" ->
Ok ( acc, tokens )
"[" -> "[" ->
-- (* extract the sub-list *) -- (* extract the sub-list *)
case expect_right_bracket tokens [] of case expect_right_bracket tokens [] of
Err msg -> Err msg Err msg ->
Err msg
Ok ( sub_list, rest ) -> Ok ( sub_list, rest ) ->
-- (* continue looking for the expected "]" *) -- (* continue looking for the expected "]" *)
case expect_right_bracket rest acc of case expect_right_bracket rest acc of
Err msg -> Err msg Err msg ->
Err msg
Ok ( el, rrest ) -> Ok ( el, rrest ) ->
Ok ((JoyList sub_list) :: el, rrest) Ok ( JoyList sub_list :: el, rrest )
_ -> _ ->
case expect_right_bracket tokens acc of case expect_right_bracket tokens acc of
Err msg -> Err msg Err msg ->
Err msg
Ok ( el, rest ) -> Ok ( el, rest ) ->
Ok ((tokenator token) :: el, rest) Ok ( tokenator token :: el, rest )
---(* token -> token list -> joy_type * token list *) ---(* token -> token list -> joy_type * token list *)
one_token_lookahead : String -> (List String) -> Result String (JoyType, List String)
one_token_lookahead : String -> List String -> Result String ( JoyType, List String )
one_token_lookahead token tokens = one_token_lookahead token tokens =
case token of case token of
"]" -> Err "Extra closing bracket." "]" ->
"[" -> case expect_right_bracket tokens [] of Err "Extra closing bracket."
Err msg -> Err msg
Ok (list_term, rest_of_tokens) -> Ok (JoyList list_term, rest_of_tokens) "[" ->
_ -> Ok (tokenator token, tokens) case expect_right_bracket tokens [] of
Err msg ->
Err msg
Ok ( list_term, rest_of_tokens ) ->
Ok ( JoyList list_term, rest_of_tokens )
_ ->
Ok ( tokenator token, tokens )
parse0 : (List String) -> JList -> Result String JList parse0 : List String -> JList -> Result String JList
parse0 tokens acc = parse0 tokens acc =
case tokens of case tokens of
[] -> Ok acc [] ->
Ok acc
token :: tokens_tail -> token :: tokens_tail ->
case one_token_lookahead token tokens_tail of case one_token_lookahead token tokens_tail of
Err msg -> Err msg Err msg ->
Err msg
Ok ( term, rest_of_tokens ) -> Ok ( term, rest_of_tokens ) ->
case parse0 rest_of_tokens acc of case parse0 rest_of_tokens acc of
Err msg -> Err msg Err msg ->
Ok terms -> Ok (term :: terms) Err msg
Ok terms ->
Ok (term :: terms)
parse tokens = parse0 tokens [] parse tokens =
parse0 tokens []
text_to_expression text = parse (tokenize text)
text_to_expression text =
parse (tokenize text)
doit : String -> JoyDict -> Result String ( String, JoyDict ) doit : String -> JoyDict -> Result String ( String, JoyDict )
@ -476,27 +721,40 @@ doit text dict =
case text_to_expression text of case text_to_expression text of
Ok ast -> Ok ast ->
case joy [] ast dict of case joy [] ast dict of
Ok (expr, dict0) -> Ok (joyExpressionToString expr, dict0) Ok ( expr, dict0 ) ->
Err msg -> Err msg Ok ( joyExpressionToString expr, dict0 )
Err msg -> Err msg
Err msg ->
Err msg
Err msg ->
Err msg
add_def : String -> JoyDict -> JoyDict add_def : String -> JoyDict -> JoyDict
add_def def dict = add_def def dict =
case text_to_expression def of case text_to_expression def of
Err msg -> dict Err msg ->
dict
Ok expr -> Ok expr ->
case expr of case expr of
[] -> dict [] ->
dict
sym :: body -> sym :: body ->
-- check that name is a symbol -- check that name is a symbol
case sym of case sym of
JoySymbol name -> (insert name body dict) JoySymbol name ->
_ -> dict insert name body dict
_ ->
dict
initialize : JoyDict -> JoyDict initialize : JoyDict -> JoyDict
initialize dict = List.foldl (add_def) dict (lines """eq [false] [true] [false] cmp initialize dict =
List.foldl add_def dict (lines """eq [false] [true] [false] cmp
gt [true] [false] [false] cmp gt [true] [false] [false] cmp
lt [false] [false] [true] cmp lt [false] [false] [true] cmp
neq [true] [false] [true] cmp neq [true] [false] [true] cmp
@ -627,4 +885,3 @@ _map2 [infrst] cons dipd roll< swons
_\\/_ [not not] [not] branch _\\/_ [not not] [not] branch
/\\ [not not] ii [pop false] [] branch /\\ [not not] ii [pop false] [] branch
\\/ [not not] ii [] [pop true] branch""") \\/ [not not] ii [] [pop true] branch""")