From babcb59da6f80d47dba02447a68f45a6185214e4 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 16 Sep 2019 11:52:52 +0100 Subject: [PATCH 001/170] minimise kernel code required for Basics.elm Ensure the compiler generated operator code is always used for operators and therefore avoid writing out kernel code definitions for basic operators. squash --- src/Basics.elm | 182 +++++++++++++++++++++++++++------------ src/Elm/Kernel/Basics.js | 43 +-------- tests/elm.json | 2 +- tests/run-tests.sh | 6 ++ 4 files changed, 139 insertions(+), 94 deletions(-) diff --git a/src/Basics.elm b/src/Basics.elm index 0c734aa4..a2cd7b2f 100644 --- a/src/Basics.elm +++ b/src/Basics.elm @@ -166,8 +166,11 @@ conversions (as Scala does) it can be even more confusing. Elm has opted for a design that makes all conversions explicit. -} add : number -> number -> number -add = - Elm.Kernel.Basics.add +add lhs rhs = + let + sum = add lhs rhs + in + sum {-| Subtract numbers like `4 - 3 == 1`. @@ -175,8 +178,11 @@ add = See [`(+)`](#+) for docs on the `number` type variable. -} sub : number -> number -> number -sub = - Elm.Kernel.Basics.sub +sub lhs rhs = + let + difference = sub lhs rhs + in + difference {-| Multiply numbers like `2 * 3 == 6`. @@ -184,9 +190,11 @@ sub = See [`(+)`](#+) for docs on the `number` type variable. -} mul : number -> number -> number -mul = - Elm.Kernel.Basics.mul - +mul lhs rhs = + let + product = mul lhs rhs + in + product {-| Floating-point division: @@ -201,8 +209,11 @@ mul = -} fdiv : Float -> Float -> Float -fdiv = - Elm.Kernel.Basics.fdiv +fdiv lhs rhs = + let + quotient = fdiv lhs rhs + in + quotient {-| Integer division: @@ -223,8 +234,11 @@ It may sometimes be useful to pair this with the [`remainderBy`](#remainderBy) function. -} idiv : Int -> Int -> Int -idiv = - Elm.Kernel.Basics.idiv +idiv lhs rhs = + let + quotient = idiv lhs rhs + in + quotient {-| Exponentiation @@ -233,8 +247,8 @@ idiv = 3^3 == 27 -} pow : number -> number -> number -pow = - Elm.Kernel.Basics.pow +pow base exponent = + Elm.Kernel.Basics.pow base exponent @@ -250,8 +264,11 @@ values like this: -} toFloat : Int -> Float -toFloat = - Elm.Kernel.Basics.toFloat +toFloat x = + let + asFloat = toFloat x + in + asFloat {-| Round a number to the nearest integer. @@ -314,8 +331,11 @@ ceiling = truncate -1.8 == -1 -} truncate : Float -> Int -truncate = - Elm.Kernel.Basics.truncate +truncate x = + let + truncated = truncate x + in + truncated @@ -342,8 +362,11 @@ if passed through a port. [undecidable]: https://en.wikipedia.org/wiki/Undecidable_problem -} eq : a -> a -> Bool -eq = - Elm.Kernel.Utils.equal +eq lhs rhs = + let + areEqual = eq lhs rhs + in + areEqual {-| Check if values are not “the same”. @@ -351,8 +374,11 @@ eq = So `(a /= b)` is the same as `(not (a == b))`. -} neq : a -> a -> Bool -neq = - Elm.Kernel.Utils.notEqual +neq lhs rhs = + let + areNotEqual = neq lhs rhs + in + areNotEqual @@ -361,26 +387,38 @@ neq = {-|-} lt : comparable -> comparable -> Bool -lt = - Elm.Kernel.Utils.lt +lt lhs rhs = + let + lhsSmaller = lt lhs rhs + in + lhsSmaller {-|-} gt : comparable -> comparable -> Bool -gt = - Elm.Kernel.Utils.gt +gt lhs rhs = + let + lhsLarger = gt lhs rhs + in + lhsLarger {-|-} le : comparable -> comparable -> Bool -le = - Elm.Kernel.Utils.le +le lhs rhs = + let + lhsSmallerOrEqual = le lhs rhs + in + lhsSmallerOrEqual {-|-} ge : comparable -> comparable -> Bool -ge = - Elm.Kernel.Utils.ge +ge lhs rhs = + let + lhsLargerOrEqual = ge lhs rhs + in + lhsLargerOrEqual {-| Find the smaller of two comparables. @@ -446,8 +484,11 @@ type Bool = True | False not False == True -} not : Bool -> Bool -not = - Elm.Kernel.Basics.not +not x = + let + complement = not x + in + complement {-| The logical AND operator. `True` if both inputs are `True`. @@ -462,8 +503,11 @@ short-circuits. This means if `left` is `False` we do not bother evaluating `rig and just return `False` overall. -} and : Bool -> Bool -> Bool -and = - Elm.Kernel.Basics.and +and lhs rhs = + let + areBothTrue = and lhs rhs + in + areBothTrue {-| The logical OR operator. `True` if one or both inputs are `True`. @@ -478,8 +522,11 @@ short-circuits. This means if `left` is `True` we do not bother evaluating `righ and just return `True` overall. -} or : Bool -> Bool -> Bool -or = - Elm.Kernel.Basics.or +or lhs rhs = + let + areEitherTrue = or lhs rhs + in + areEitherTrue {-| The exclusive-or operator. `True` if exactly one input is `True`. @@ -490,8 +537,11 @@ or = xor False False == False -} xor : Bool -> Bool -> Bool -xor = - Elm.Kernel.Basics.xor +xor lhs rhs = + let + isOneTrue = xor lhs rhs + in + isOneTrue @@ -504,8 +554,11 @@ xor = [1,1,2] ++ [3,5,8] == [1,1,2,3,5,8] -} append : appendable -> appendable -> appendable -append = - Elm.Kernel.Utils.append +append lhs rhs = + let + appended = append lhs rhs + in + appended @@ -533,12 +586,20 @@ information. [dm]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf -} modBy : Int -> Int -> Int -modBy = - Elm.Kernel.Basics.modBy +modBy modulus x = + let + answer = + remainderBy modulus x + in + if eq modulus 0 then + Elm.Kernel.Basics.modBy0 () + else if or (and (gt answer 0) (lt modulus 0)) (and (lt answer 0) (gt modulus 0)) then + add answer modulus + else + answer {-| Get the remainder after division. Here are bunch of examples of dividing by four: - List.map (remainderBy 4) [ -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 ] -- [ -1, 0, -3, -2, -1, 0, 1, 2, 3, 0, 1 ] @@ -549,8 +610,11 @@ information. [dm]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf -} remainderBy : Int -> Int -> Int -remainderBy = - Elm.Kernel.Basics.remainderBy +remainderBy divisor dividend = + let + remainder = remainderBy divisor dividend + in + remainder {-| Negate a number. @@ -560,8 +624,12 @@ remainderBy = negate 0 == 0 -} negate : number -> number -negate n = - -n +negate x = + let + negated = negate x + in + negated + {-| Get the [absolute value][abs] of a number. @@ -623,7 +691,7 @@ logBase base number = -} e : Float e = - Elm.Kernel.Basics.e + 2.7182818284590452353602874713526624977572470 @@ -665,7 +733,7 @@ turns angleInTurns = -} pi : Float pi = - Elm.Kernel.Basics.pi + 3.14159265358979323851280895 {-| Figure out the cosine given an angle in radians. @@ -805,8 +873,8 @@ numbers](https://en.wikipedia.org/wiki/NaN). isNaN 1 == False -} isNaN : Float -> Bool -isNaN = - Elm.Kernel.Basics.isNaN +isNaN n = + neq n n {-| Determine whether a float is positive or negative infinity. @@ -820,8 +888,8 @@ Notice that NaN is not infinite! For float `n` to be finite implies that `not (isInfinite n || isNaN n)` evaluates to `True`. -} isInfinite : Float -> Bool -isInfinite = - Elm.Kernel.Basics.isInfinite +isInfinite n = + eq (abs n) (fdiv 1 0) @@ -889,7 +957,10 @@ Testing the logic gets easier too. Nice side benefit! -} apR : a -> (a -> b) -> b apR x f = - f x + let + applied = apR x f + in + applied {-| Saying `f <| x` is exactly the same as `f x`. @@ -899,7 +970,10 @@ to apply a function to a `case` expression? That sort of thing. -} apL : (a -> b) -> a -> b apL f x = - f x + let + applied = apL f x + in + applied {-| Given a value, returns exactly the same value. This is called diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 049291f9..85307e20 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -4,35 +4,10 @@ import Elm.Kernel.Debug exposing (crash) */ - // MATH -var _Basics_add = F2(function(a, b) { return a + b; }); -var _Basics_sub = F2(function(a, b) { return a - b; }); -var _Basics_mul = F2(function(a, b) { return a * b; }); -var _Basics_fdiv = F2(function(a, b) { return a / b; }); -var _Basics_idiv = F2(function(a, b) { return (a / b) | 0; }); var _Basics_pow = F2(Math.pow); -var _Basics_remainderBy = F2(function(b, a) { return a % b; }); - -// https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf -var _Basics_modBy = F2(function(modulus, x) -{ - var answer = x % modulus; - return modulus === 0 - ? __Debug_crash(11) - : - ((answer > 0 && modulus < 0) || (answer < 0 && modulus > 0)) - ? answer + modulus - : answer; -}); - - -// TRIGONOMETRY - -var _Basics_pi = Math.PI; -var _Basics_e = Math.E; var _Basics_cos = Math.cos; var _Basics_sin = Math.sin; var _Basics_tan = Math.tan; @@ -42,23 +17,13 @@ var _Basics_atan = Math.atan; var _Basics_atan2 = F2(Math.atan2); -// MORE MATH - -function _Basics_toFloat(x) { return x; } -function _Basics_truncate(n) { return n | 0; } -function _Basics_isInfinite(n) { return n === Infinity || n === -Infinity; } - var _Basics_ceiling = Math.ceil; var _Basics_floor = Math.floor; var _Basics_round = Math.round; var _Basics_sqrt = Math.sqrt; var _Basics_log = Math.log; -var _Basics_isNaN = isNaN; - -// BOOLEANS - -function _Basics_not(bool) { return !bool; } -var _Basics_and = F2(function(a, b) { return a && b; }); -var _Basics_or = F2(function(a, b) { return a || b; }); -var _Basics_xor = F2(function(a, b) { return a !== b; }); +var _Basics_modBy0 = function() +{ + __Debug_crash(11) +}; diff --git a/tests/elm.json b/tests/elm.json index 4bd92d12..3c64414c 100644 --- a/tests/elm.json +++ b/tests/elm.json @@ -1,7 +1,7 @@ { "type": "application", "source-directories": [], - "elm-version": "0.19.0", + "elm-version": "0.19.1", "dependencies": { "direct": { "elm/browser": "1.0.1", diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 3258d5fb..d31a7040 100755 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -39,8 +39,11 @@ echo "seeding framework for test dependencies ..."; # '|| true' lets us ignore failures here and keep the script running. # useful when developing a fix for a bug that exists in the version of # elm/core hosted on package.elm-lang.org + "${ELM_TEST}" tests/Main.elm --fuzz=1 > /dev/null || true; +# elm make tests/Main2.elm --output ./tmp.js + # clear out the copy of elm-core fetched by the above and replace it # with the local source code we want to actually test @@ -68,3 +71,6 @@ echo "running tests ..."; echo; "${ELM_TEST}" tests/Main.elm $@; + +# elm make tests/Main2.elm --output ./tmp.js +# node tmp From 91b2a24d42e2bb073ac4ec29e052d9055d29e58f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 25 Oct 2019 22:26:51 +0100 Subject: [PATCH 002/170] test: fix test runner for elm 0.19.1 --- tests/run-tests.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/run-tests.sh b/tests/run-tests.sh index d31a7040..31cc2ac1 100755 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -47,8 +47,8 @@ echo "seeding framework for test dependencies ..."; # clear out the copy of elm-core fetched by the above and replace it # with the local source code we want to actually test -VERSION_DIR="$(ls ${ELM_HOME}/0.19.0/package/elm/core/)" -CORE_PACKAGE_DIR="${ELM_HOME}/0.19.0/package/elm/core/$VERSION_DIR" +VERSION_DIR="$(ls ${ELM_HOME}/0.19.1/packages/elm/core/)" +CORE_PACKAGE_DIR="${ELM_HOME}/0.19.1/packages/elm/core/$VERSION_DIR" CORE_GIT_DIR="$(dirname $PWD)" echo; From f5d60249a59e41debb50055d2618ab2881e79473 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 25 Oct 2019 22:47:52 +0100 Subject: [PATCH 003/170] avoid kernel code in Basics.elm Allow the compiler to generate js op's instead. --- src/Bitwise.elm | 54 ++++++++++++++++++++++++++++----------- src/Elm/Kernel/Bitwise.js | 39 ---------------------------- 2 files changed, 39 insertions(+), 54 deletions(-) delete mode 100644 src/Elm/Kernel/Bitwise.js diff --git a/src/Bitwise.elm b/src/Bitwise.elm index bd488fc5..5195049f 100644 --- a/src/Bitwise.elm +++ b/src/Bitwise.elm @@ -21,30 +21,43 @@ import Elm.Kernel.Bitwise {-| Bitwise AND -} and : Int -> Int -> Int -and = - Elm.Kernel.Bitwise.and +and lhs rhs = + let + res = and lhs rhs + in + res {-| Bitwise OR -} or : Int -> Int -> Int -or = - Elm.Kernel.Bitwise.or +or lhs rhs = + let + res = or lhs rhs + in + res + {-| Bitwise XOR -} xor : Int -> Int -> Int -xor = - Elm.Kernel.Bitwise.xor +xor lhs rhs = + let + res = xor lhs rhs + in + res + {-| Flip each bit individually, often called bitwise NOT -} complement : Int -> Int -complement = - Elm.Kernel.Bitwise.complement - +complement x = + let + res = complement x + in + res {-| Shift bits to the left by a given offset, filling new bits with zeros. This can be used to multiply numbers by powers of two. @@ -53,8 +66,12 @@ This can be used to multiply numbers by powers of two. shiftLeftBy 5 1 == 32 -} shiftLeftBy : Int -> Int -> Int -shiftLeftBy = - Elm.Kernel.Bitwise.shiftLeftBy +shiftLeftBy lhs rhs = + let + res = shiftLeftBy lhs rhs + in + res + {-| Shift bits to the right by a given offset, filling new bits with @@ -71,8 +88,12 @@ with copies of the highest bit. [ars]: https://en.wikipedia.org/wiki/Bitwise_operation#Arithmetic_shift -} shiftRightBy : Int -> Int -> Int -shiftRightBy = - Elm.Kernel.Bitwise.shiftRightBy +shiftRightBy lhs rhs = + let + res = shiftRightBy lhs rhs + in + res + {-| Shift bits to the right by a given offset, filling new bits with zeros. @@ -88,6 +109,9 @@ zeros. [lrs]: https://en.wikipedia.org/wiki/Bitwise_operation#Logical_shift -} shiftRightZfBy : Int -> Int -> Int -shiftRightZfBy = - Elm.Kernel.Bitwise.shiftRightZfBy +shiftRightZfBy lhs rhs = + let + res = shiftRightZfBy lhs rhs + in + res diff --git a/src/Elm/Kernel/Bitwise.js b/src/Elm/Kernel/Bitwise.js deleted file mode 100644 index 612e8c7c..00000000 --- a/src/Elm/Kernel/Bitwise.js +++ /dev/null @@ -1,39 +0,0 @@ -/* - -*/ - - -var _Bitwise_and = F2(function(a, b) -{ - return a & b; -}); - -var _Bitwise_or = F2(function(a, b) -{ - return a | b; -}); - -var _Bitwise_xor = F2(function(a, b) -{ - return a ^ b; -}); - -function _Bitwise_complement(a) -{ - return ~a; -}; - -var _Bitwise_shiftLeftBy = F2(function(offset, a) -{ - return a << offset; -}); - -var _Bitwise_shiftRightBy = F2(function(offset, a) -{ - return a >> offset; -}); - -var _Bitwise_shiftRightZfBy = F2(function(offset, a) -{ - return a >>> offset; -}); From dbf29e35874118c4cf8443a7ea32a8339ad8f94d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 26 Oct 2019 11:32:03 +0100 Subject: [PATCH 004/170] implement List.mapN without kernel code --- src/List.elm | 49 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 41 insertions(+), 8 deletions(-) diff --git a/src/List.elm b/src/List.elm index 9ef2b176..d812a197 100644 --- a/src/List.elm +++ b/src/List.elm @@ -429,28 +429,61 @@ If one list is longer, the extra elements are dropped. -} map2 : (a -> b -> result) -> List a -> List b -> List result -map2 = - Elm.Kernel.List.map2 +map2 f xs1 xs2 = + reverse (map2Help f xs1 xs2 []) {-|-} map3 : (a -> b -> c -> result) -> List a -> List b -> List c -> List result -map3 = - Elm.Kernel.List.map3 +map3 f xs1 xs2 xs3 = + reverse (map3Help f xs1 xs2 xs3 []) {-|-} map4 : (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result -map4 = - Elm.Kernel.List.map4 +map4 f xs1 xs2 xs3 xs4 = + reverse (map4Help f xs1 xs2 xs3 xs4 []) {-|-} map5 : (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result -map5 = - Elm.Kernel.List.map5 +map5 f xs1 xs2 xs3 xs4 xs5 = + reverse (map5Help f xs1 xs2 xs3 xs4 xs5 []) +map2Help : (a -> b -> result) -> List a -> List b -> List result -> List result +map2Help f xs1 xs2 ys = + case (xs1, xs2) of + (head1 :: rest1, head2 :: rest2) -> + map2Help f rest1 rest2 (cons (f head1 head2) ys) + _ -> + ys + +map3Help : (a -> b -> c -> result) -> List a -> List b -> List c-> List result -> List result +map3Help f xs1 xs2 xs3 ys = + case (xs1, xs2, xs3) of + (head1 :: rest1, head2 :: rest2, head3 :: rest3) -> + map3Help f rest1 rest2 rest3 (cons (f head1 head2 head3) ys) + _ -> + ys + +map4Help : (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result -> List result +map4Help f xs1 xs2 xs3 xs4 ys = + case (xs1, xs2, (xs3, xs4)) of + (head1 :: rest1, head2 :: rest2, (head3 :: rest3, head4 :: rest4)) -> + map4Help f rest1 rest2 rest3 rest4 (cons (f head1 head2 head3 head4) ys) + _ -> + ys + + +map5Help : (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result -> List result +map5Help f xs1 xs2 xs3 xs4 xs5 ys = + case (xs1, xs2, (xs3, xs4, xs5)) of + (head1 :: rest1, head2 :: rest2, (head3 :: rest3, head4 :: rest4, head5 :: rest5)) -> + map5Help f rest1 rest2 rest3 rest4 rest5 (cons (f head1 head2 head3 head4 head5) ys) + _ -> + ys + -- SORT From d7fef33833e9197e70cbdb28f25c817e93169992 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 26 Oct 2019 12:26:26 +0100 Subject: [PATCH 005/170] add more tests for List.mapN --- tests/tests/Test/List.elm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/tests/Test/List.elm b/tests/tests/Test/List.elm index 52b361f4..b78c43db 100644 --- a/tests/tests/Test/List.elm +++ b/tests/tests/Test/List.elm @@ -41,6 +41,9 @@ testListOfN n = mid = n // 2 + + possiblySingletonHi = + List.repeat (min 1 n) "hi" in describe (String.fromInt n ++ " elements") [ describe "foldl" @@ -104,6 +107,18 @@ testListOfN n = , test "long first" <| \() -> Expect.equal (map (\x -> x * 2 - 1) xs) (map2 (+) zs xs) , test "short first" <| \() -> Expect.equal (map (\x -> x * 2 - 1) xs) (map2 (+) xs zs) ] + , describe "map3" + [ test "same length" <| \() -> Expect.equal (map ((*) 3) xs) (map3 (\a b c -> a + b + c) xs xs xs) + , test "length is the shortest" <| \() -> Expect.equal possiblySingletonHi (map3 (\_ x _ -> x) xs [ "hi" ] xs) + ] + , describe "map4" + [ test "same length" <| \() -> Expect.equal (map ((*) 4) xs) (map4 (\a b c d -> a + b + c + d) xs xs xs xs) + , test "length is the shortest" <| \() -> Expect.equal possiblySingletonHi (map4 (\_ _ x _ -> x) xs xs [ "hi" ] xs) + ] + , describe "map5" + [ test "same length" <| \() -> Expect.equal (map ((*) 5) xs) (map5 (\a b c d e -> a + b + c + d + e) xs xs xs xs xs) + , test "length is the shortest" <| \() -> Expect.equal possiblySingletonHi (map5 (\_ x _ _ _ -> x) xs [ "hi" ] xs xs xs) + ] , test "unzip" <| \() -> Expect.equal ( xsNeg, xs ) (map (\x -> ( -x, x )) xs |> unzip) , describe "filterMap" [ test "none" <| \() -> Expect.equal ([]) (filterMap (\x -> Nothing) xs) From 2627e4d12b690c56ba84edf86d8605f9f5e8c245 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 9 Nov 2019 23:31:36 +0000 Subject: [PATCH 006/170] util: add custom-core script Sourcing this script will link the current directory into ELM_HOME. Future compiles (in current shell) will use the custom core version. Make sure to delete elm-stuff in your project directory after running the script. --- custom-core.sh | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100755 custom-core.sh diff --git a/custom-core.sh b/custom-core.sh new file mode 100755 index 00000000..3f1cb5df --- /dev/null +++ b/custom-core.sh @@ -0,0 +1,35 @@ + +if [[ ! -v ELM_HOME ]] || [[ $ELM_HOME != */custom-core ]]; then + export ELM_HOME="${ELM_HOME:-"$HOME/.elm"}/custom-core"; +fi + +bash <<"EOF" + +set -o errexit; +set -o nounset; + +printf "Sucess if ends with DONE: " + +ELM="${ELM:-elm}" +ELM_VERSION="$($ELM --version)" +IFS=- read ELM_VERSION_START IGNORE <<< "$ELM_VERSION" + +rm -rf elm-minimal-master +curl -sL https://github.com/harrysarson/elm-minimal/archive/master.tar.gz | tar xz +cd elm-minimal-master +$ELM make src/Main.elm --output /dev/null > /dev/null || true; +cd - > /dev/null +rm -rf elm-minimal-master + + +CORE_VERSION="$(ls $ELM_HOME/$ELM_VERSION/packages/elm/core/)" +CORE_PACKAGE_DIR="$ELM_HOME/$ELM_VERSION/packages/elm/core/$CORE_VERSION" +CORE_GIT_DIR=$(pwd) + +rm -rf "$CORE_PACKAGE_DIR" > /dev/null +ln -sv "$CORE_GIT_DIR" "$CORE_PACKAGE_DIR" > /dev/null +rm -vf "${CORE_GIT_DIR}"/*.dat "${CORE_GIT_DIR}"/doc*.json > /dev/null + +printf "DONE\n" + +EOF From bdf62c11e959919cecdf693ee1dd88204d8280ef Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 12 Nov 2019 21:02:16 +0000 Subject: [PATCH 007/170] add list map benchmarks --- benchmark/.gitignore | 1 + benchmark/elm.json | 29 ++++++++++++ benchmark/src/Main.elm | 104 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 134 insertions(+) create mode 100644 benchmark/.gitignore create mode 100644 benchmark/elm.json create mode 100644 benchmark/src/Main.elm diff --git a/benchmark/.gitignore b/benchmark/.gitignore new file mode 100644 index 00000000..aee98106 --- /dev/null +++ b/benchmark/.gitignore @@ -0,0 +1 @@ +/elm-stuff/ diff --git a/benchmark/elm.json b/benchmark/elm.json new file mode 100644 index 00000000..776d8656 --- /dev/null +++ b/benchmark/elm.json @@ -0,0 +1,29 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "elm/browser": "1.0.1", + "elm/core": "1.0.2", + "elm/html": "1.0.0", + "elm-explorations/benchmark": "1.0.1" + }, + "indirect": { + "BrianHicks/elm-trend": "2.1.3", + "Skinney/murmur3": "2.0.8", + "elm/json": "1.1.3", + "elm/regex": "1.0.0", + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.2", + "mdgriffith/style-elements": "5.0.1" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} diff --git a/benchmark/src/Main.elm b/benchmark/src/Main.elm new file mode 100644 index 00000000..b22fe411 --- /dev/null +++ b/benchmark/src/Main.elm @@ -0,0 +1,104 @@ + +module Main exposing (..) + +import Benchmark.Runner exposing (BenchmarkProgram, program) + +import Array +import Benchmark exposing (..) +import List exposing (reverse) + + +main : BenchmarkProgram +main = + program suite + +cons : a -> List a -> List a +cons = + (::) + + +map2 : (a -> b -> result) -> List a -> List b -> List result +map2 f xs1 xs2 = + map5 (\a b _ _ _ -> f a b) xs1 xs2 xs1 xs1 xs1 + + +{-|-} +map3 : (a -> b -> c -> result) -> List a -> List b -> List c -> List result +map3 f xs1 xs2 xs3 = + map5 (\a b c _ _ -> f a b c) xs1 xs2 xs3 xs1 xs1 + + +{-|-} +map4 : (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result +map4 f xs1 xs2 xs3 xs4 = + map5 (\a b c d _ -> f a b c d) xs1 xs2 xs3 xs4 xs1 + + + +{-|-} +map5 : (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result +map5 = + List.map5 + +map2Help : (a -> b -> result) -> List a -> List b -> List result -> List result +map2Help f xs1 xs2 ys = + case (xs1, xs2) of + (head1 :: rest1, head2 :: rest2) -> + map2Help f rest1 rest2 (cons (f head1 head2) ys) + _ -> + ys + +map3Help : (a -> b -> c -> result) -> List a -> List b -> List c-> List result -> List result +map3Help f xs1 xs2 xs3 ys = + case (xs1, xs2, xs3) of + (head1 :: rest1, head2 :: rest2, head3 :: rest3) -> + map3Help f rest1 rest2 rest3 (cons (f head1 head2 head3) ys) + _ -> + ys + +map4Help : (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result -> List result +map4Help f xs1 xs2 xs3 xs4 ys = + case (xs1, xs2, (xs3, xs4)) of + (head1 :: rest1, head2 :: rest2, (head3 :: rest3, head4 :: rest4)) -> + map4Help f rest1 rest2 rest3 rest4 (cons (f head1 head2 head3 head4) ys) + _ -> + ys + + +map5Help : (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result -> List result +map5Help f xs1 xs2 xs3 xs4 xs5 ys = + case (xs1, xs2, (xs3, xs4, xs5)) of + (head1 :: rest1, head2 :: rest2, (head3 :: rest3, head4 :: rest4, head5 :: rest5)) -> + map5Help f rest1 rest2 rest3 rest4 rest5 (cons (f head1 head2 head3 head4 head5) ys) + _ -> + ys + + +suite : Benchmark +suite = + let + sampleList = + List.range 0 4999 + in + describe "mapping" + [ Benchmark.compare "map2" + "no kernel" + (\_ -> map2 (\a b -> a + b) sampleList sampleList) + "core" + (\_ -> List.map2 (\a b -> a + b) sampleList sampleList) + , Benchmark.compare "map3" + "no kernel" + (\_ -> map3 (\a b c -> a + b + c) sampleList sampleList sampleList) + "core" + (\_ -> List.map3 (\a b c -> a + b + c) sampleList sampleList sampleList) + , Benchmark.compare "map4" + "no kernel" + (\_ -> map4 (\a b c d -> a + b + c + d) sampleList sampleList sampleList sampleList) + "core" + (\_ -> List.map4 (\a b c d -> a + b + c + d) sampleList sampleList sampleList sampleList) + , Benchmark.compare "map5" + "no kernel" + (\_ -> map5 (\a b c d e -> a + b + c + d + e) sampleList sampleList sampleList sampleList sampleList) + "core" + (\_ -> List.map5 (\a b c d e -> a + b + c + d + e) sampleList sampleList sampleList sampleList sampleList) + ] From 886f0b6da4eaec23bd6d8a1988b123b629ac244d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 12 Nov 2019 21:02:36 +0000 Subject: [PATCH 008/170] add operator comutivity tests --- tests/tests/Test/Basics.elm | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tests/tests/Test/Basics.elm b/tests/tests/Test/Basics.elm index 323ae15d..bae9b52c 100644 --- a/tests/tests/Test/Basics.elm +++ b/tests/tests/Test/Basics.elm @@ -10,6 +10,7 @@ import Expect exposing (FloatingPointTolerance(..)) import List import String import Debug exposing (toString) +import Fuzz tests : Test @@ -202,6 +203,24 @@ tests = |> Expect.equal [ "SaN" ] ] ] + + operatorTests = + describe "Operators" + [ describe "Comutivity" + [ fuzz2 Fuzz.int Fuzz.int "Int + Int" <| \a b -> Expect.equal (a + b) (b + a) + , fuzz2 Fuzz.float Fuzz.float "Float + Float" <| \a b -> Expect.within (AbsoluteOrRelative 1e-10 1e-10) (a + b) (b + a) + , fuzz2 Fuzz.int Fuzz.int "Int - Int" <| \a b -> Expect.equal (a - b) (-(b - a)) + , fuzz2 Fuzz.float Fuzz.float "Float - Float" <| \a b -> Expect.within (AbsoluteOrRelative 1e-10 1e-10) (a - b) (-(b - a)) + , fuzz2 Fuzz.int Fuzz.int "Int * Int" <| \a b -> Expect.equal (a * b) (b * a) + , fuzz2 Fuzz.float Fuzz.float "Float * Float" <| \a b -> Expect.within (AbsoluteOrRelative 1e-10 1e-10) (a * b) (b * a) + , fuzz2 Fuzz.float Fuzz.float "Float / Float" <| + \a b -> + if b == 0 then + Expect.pass + else + Expect.within (AbsoluteOrRelative 1e-10 1e-10) (a / b) (1 / (b / a)) + ] + ] in describe "Basics" [ comparison @@ -211,4 +230,5 @@ tests = , booleanTests , miscTests , higherOrderTests + , operatorTests ] From 013b47f6152a80a79174f92dae69fcf356e9969c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 12 Nov 2019 21:53:39 +0000 Subject: [PATCH 009/170] update custom-core script --- custom-core.sh | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/custom-core.sh b/custom-core.sh index 3f1cb5df..8a678b03 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -1,30 +1,34 @@ - -if [[ ! -v ELM_HOME ]] || [[ $ELM_HOME != */custom-core ]]; then - export ELM_HOME="${ELM_HOME:-"$HOME/.elm"}/custom-core"; -fi - -bash <<"EOF" +#! /usr/bin/env bash set -o errexit; set -o nounset; +if [[ ! -v ELM_HOME ]]; then + eprintf "Please set ELM_HOME!" + exit 1 +fi + printf "Sucess if ends with DONE: " ELM="${ELM:-elm}" ELM_VERSION="$($ELM --version)" IFS=- read ELM_VERSION_START IGNORE <<< "$ELM_VERSION" -rm -rf elm-minimal-master -curl -sL https://github.com/harrysarson/elm-minimal/archive/master.tar.gz | tar xz +rm -rf "$ELM_HOME/$ELM_VERSION/packages/elm/core/" + +if [[ ! -d elm-minimal-master ]]; then + curl -sL https://github.com/harrysarson/elm-minimal/archive/master.tar.gz | tar xz +fi + cd elm-minimal-master +rm -rf elm-stuff $ELM make src/Main.elm --output /dev/null > /dev/null || true; cd - > /dev/null -rm -rf elm-minimal-master CORE_VERSION="$(ls $ELM_HOME/$ELM_VERSION/packages/elm/core/)" CORE_PACKAGE_DIR="$ELM_HOME/$ELM_VERSION/packages/elm/core/$CORE_VERSION" -CORE_GIT_DIR=$(pwd) +CORE_GIT_DIR=$(realpath $1) rm -rf "$CORE_PACKAGE_DIR" > /dev/null ln -sv "$CORE_GIT_DIR" "$CORE_PACKAGE_DIR" > /dev/null @@ -32,4 +36,3 @@ rm -vf "${CORE_GIT_DIR}"/*.dat "${CORE_GIT_DIR}"/doc*.json > /dev/null printf "DONE\n" -EOF From f8244274d01270ea423dccaf4186016dacef01fa Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 12 Nov 2019 22:20:59 +0000 Subject: [PATCH 010/170] remove old import from bitwise --- src/Bitwise.elm | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Bitwise.elm b/src/Bitwise.elm index 5195049f..9c49f6bc 100644 --- a/src/Bitwise.elm +++ b/src/Bitwise.elm @@ -14,7 +14,6 @@ module Bitwise exposing import Basics exposing (Int) -import Elm.Kernel.Bitwise From 2af7d2d71b78124f6c8d15c2c942937eac283f62 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 12 Nov 2019 22:37:03 +0000 Subject: [PATCH 011/170] Use an elm type for Cmd bags A first step towards moving platform logic into elm. We define Cmds and Subs as elm types (with a fair bit of trickery). Works in dev and optimise modes! --- src/Elm/Kernel/Basics.js | 4 +++ src/Elm/Kernel/Platform.js | 73 +++++++++++++++++++++++--------------- src/Platform/Bag.elm | 48 +++++++++++++++++++++++++ src/Platform/Cmd.elm | 17 +++++---- src/Platform/Sub.elm | 16 +++++---- 5 files changed, 116 insertions(+), 42 deletions(-) create mode 100644 src/Platform/Bag.elm diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 85307e20..455e4529 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -27,3 +27,7 @@ var _Basics_modBy0 = function() { __Debug_crash(11) }; + +var _Basics_fudge_type = function(x) { + return x; +}; diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index c1726550..8e791aac 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -173,47 +173,41 @@ var _Platform_sendToSelf = F2(function(router, msg) // BAGS +// Called by compiler generated js for event managers function _Platform_leaf(home) { return function(value) { + /**__DEBUG/ return { - $: __2_LEAF, + $: 'Value', + a: { + $: 'Leaf', + __home: home, + __value: value + } + }; + //*/ + + /**__PROD/ + return { + $: 0, __home: home, __value: value }; + //*/ }; } -function _Platform_batch(list) -{ - return { - $: __2_NODE, - __bags: list - }; -} - - -var _Platform_map = F2(function(tagger, bag) -{ - return { - $: __2_MAP, - __func: tagger, - __bag: bag - } -}); - - - // PIPE BAGS INTO EFFECT MANAGERS function _Platform_dispatchEffects(managers, cmdBag, subBag) { var effectsDict = {}; - _Platform_gatherEffects(true, cmdBag, effectsDict, null); - _Platform_gatherEffects(false, subBag, effectsDict, null); + _Platform_gatherEffects(true, _Platform__unwrap_bag(cmdBag), effectsDict, null); + _Platform_gatherEffects(false, _Platform__unwrap_bag(subBag), effectsDict, null); for (var home in managers) { @@ -224,27 +218,48 @@ function _Platform_dispatchEffects(managers, cmdBag, subBag) } } +function _Platform__unwrap_bag(cmdOrSub) +{ + /**__DEBUG/ + return cmdOrSub.a; + //*/ + + /**__PROD/ + return cmdOrSub; + //*/ +} function _Platform_gatherEffects(isCmd, bag, effectsDict, taggers) { + /**__DEBUG/ + const LEAF = 'Leaf'; + const BATCH = 'Batch'; + const MAP = 'Map'; + //*/ + + /**__PROD/ + const LEAF = 0; + const BATCH = 1; + const MAP = 2; + //*/ switch (bag.$) { - case __2_LEAF: + case LEAF: var home = bag.__home; var effect = _Platform_toEffect(isCmd, home, taggers, bag.__value); effectsDict[home] = _Platform_insert(isCmd, effect, effectsDict[home]); return; - case __2_NODE: - for (var list = bag.__bags; list.b; list = list.b) // WHILE_CONS + case BATCH: + for (let list = bag.a; list.b; list = list.b) // WHILE_CONS { _Platform_gatherEffects(isCmd, list.a, effectsDict, taggers); } return; - case __2_MAP: - _Platform_gatherEffects(isCmd, bag.__bag, effectsDict, { - __tagger: bag.__func, + case MAP: + _Platform_gatherEffects(isCmd, bag.a, effectsDict, { + __tagger: bag.b, __rest: taggers }); return; diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm new file mode 100644 index 00000000..b26ed959 --- /dev/null +++ b/src/Platform/Bag.elm @@ -0,0 +1,48 @@ +module Platform.Bag exposing + ( Bag + , batch + , map + ) + +{-| + +> **Note:** Elm has **managed effects**, meaning that things like HTTP +> requests or writing to disk are all treated as *data* in Elm. When this +> data is given to the Elm runtime system, it can do some “query optimization” +> before actually performing the effect. Perhaps unexpectedly, this managed +> effects idea is the heart of why Elm is so nice for testing, reuse, +> reproducibility, etc. +> +> Elm has two kinds of managed effects: commands and subscriptions. + +# Commands +@docs Bag, none, batch + +# Fancy Stuff +@docs map + +-} + +import String exposing (String) +import Basics exposing (Never) + +{-| Generic bag type, for Cmds or Subs. + +Any changes to this type definition need to be reflected in Elm/Kernel/Platform.js +-} +type Bag msg + = Leaf -- let kernel code handle this one + | Batch (List (Bag msg)) + | Map (BagHiddenValue -> msg) (Bag BagHiddenValue) + + +batch : List (Bag msg) -> Bag msg +batch bag = + Batch bag + + +map : (a -> msg) -> Bag a -> Bag msg +map fn bag = + Map (Elm.Kernel.Basics.fudgeType fn) (Elm.Kernel.Basics.fudgeType bag) + +type BagHiddenValue = BagHiddenValue Never diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 8ee7683b..1ccf4445 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -24,7 +24,9 @@ module Platform.Cmd exposing -} -import Elm.Kernel.Platform +import Platform.Bag +import Basics exposing ((>>)) +import List @@ -44,7 +46,8 @@ ever, commands will make more sense as you work through [the Elm Architecture Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! -} -type Cmd msg = Cmd +type Cmd msg = + Value (Platform.Bag.Bag msg) {-| Tell the runtime that there are no commands. @@ -65,7 +68,9 @@ all do the same thing. -} batch : List (Cmd msg) -> Cmd msg batch = - Elm.Kernel.Platform.batch + List.map (\(Value bag) -> bag) + >> Platform.Bag.batch + >> Value @@ -81,7 +86,5 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Cmd a -> Cmd msg -map = - Elm.Kernel.Platform.map - - +map fn (Value bag) = + Value (Platform.Bag.map fn bag) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 66f98481..0fcf7994 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -23,8 +23,9 @@ module Platform.Sub exposing @docs map -} -import Elm.Kernel.Platform - +import Platform.Bag +import Basics exposing ((>>)) +import List -- SUBSCRIPTIONS @@ -46,7 +47,8 @@ ever, subscriptions will make more sense as you work through [the Elm Architectu Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! -} -type Sub msg = Sub +type Sub msg + = Value (Platform.Bag.Bag msg) {-| Tell the runtime that there are no subscriptions. @@ -64,7 +66,9 @@ subscriptions. -} batch : List (Sub msg) -> Sub msg batch = - Elm.Kernel.Platform.batch + List.map (\(Value bag) -> bag) + >> Platform.Bag.batch + >> Value @@ -80,5 +84,5 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Sub a -> Sub msg -map = - Elm.Kernel.Platform.map +map fn (Value bag) = + Value (Platform.Bag.map fn bag) From ed13487b13b2fa1c11a336bde795f27b3cd6abbb Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 16 Nov 2019 12:23:32 +0000 Subject: [PATCH 012/170] fix errors in previous commit --- src/Elm/Kernel/Basics.js | 2 +- src/Elm/Kernel/Platform.js | 4 ++-- src/Platform/Bag.elm | 20 -------------------- 3 files changed, 3 insertions(+), 23 deletions(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 455e4529..b8c33e63 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -28,6 +28,6 @@ var _Basics_modBy0 = function() __Debug_crash(11) }; -var _Basics_fudge_type = function(x) { +var _Basics_fudgeType = function(x) { return x; }; diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 8e791aac..14441329 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -258,8 +258,8 @@ function _Platform_gatherEffects(isCmd, bag, effectsDict, taggers) return; case MAP: - _Platform_gatherEffects(isCmd, bag.a, effectsDict, { - __tagger: bag.b, + _Platform_gatherEffects(isCmd, bag.b, effectsDict, { + __tagger: bag.a, __rest: taggers }); return; diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index b26ed959..e843e065 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -4,26 +4,6 @@ module Platform.Bag exposing , map ) -{-| - -> **Note:** Elm has **managed effects**, meaning that things like HTTP -> requests or writing to disk are all treated as *data* in Elm. When this -> data is given to the Elm runtime system, it can do some “query optimization” -> before actually performing the effect. Perhaps unexpectedly, this managed -> effects idea is the heart of why Elm is so nice for testing, reuse, -> reproducibility, etc. -> -> Elm has two kinds of managed effects: commands and subscriptions. - -# Commands -@docs Bag, none, batch - -# Fancy Stuff -@docs map - --} - -import String exposing (String) import Basics exposing (Never) {-| Generic bag type, for Cmds or Subs. From 93161285a333a8b835b5a800fdf55762ff5ee92f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 16 Nov 2019 15:35:48 +0000 Subject: [PATCH 013/170] fix: add missing self case for Bag Turns out that there is a fourth type of Bag in elm. This type is for messages that are sent from an event manager to its self. I do not really understand these. Next step is to find an SSCCE that fails without this patch. --- src/Elm/Kernel/Platform.js | 20 ++++++++++++++++++-- src/Platform/Bag.elm | 1 + 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 14441329..26fd57e5 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -131,7 +131,13 @@ function _Platform_instantiateManager(info, sendToApp) { var value = msg.a; - if (msg.$ === __2_SELF) + /**__DEBUG/ + if (msg.$ === 'Self') + //*/ + + /**__PROD/ + if (msg.$ === 3) + //*/ { return A3(onSelfMsg, router, value, state); } @@ -163,8 +169,18 @@ var _Platform_sendToApp = F2(function(router, msg) var _Platform_sendToSelf = F2(function(router, msg) { return A2(__Scheduler_send, router.__selfProcess, { - $: __2_SELF, + /**__DEBUG/ + $: 'Value', + a: { + $: 'Self', + a: msg + } + //*/ + + /**__PROD/ + $: 3, a: msg + //*/ }); }); diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index e843e065..1d588f3b 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -14,6 +14,7 @@ type Bag msg = Leaf -- let kernel code handle this one | Batch (List (Bag msg)) | Map (BagHiddenValue -> msg) (Bag BagHiddenValue) + | Self -- kernel code gets this one too batch : List (Bag msg) -> Bag msg From 5eff30af732500c2cf0fcf4c1dd05e176c667035 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 17 Nov 2019 16:15:56 +0000 Subject: [PATCH 014/170] WIP --- design-documents/OperatorExample.elm | 33 + .../elm-minimal-master/.gitignore | 1 + design-documents/elm-minimal-master/elm.json | 24 + design-documents/elm-minimal-master/main.js | 2832 +++++++++++++++++ .../elm-minimal-master/src/Main.elm | 31 + .../src/OperatorExample.elm | 1 + design-documents/operators.md | 337 ++ design-documents/table.html | 52 + src/Elm/Kernel/Platform.js | 2 +- src/Elm/Kernel/Scheduler.js | 245 +- src/Platform.elm | 34 +- src/Platform/Bag.elm | 4 +- src/Platform/Scheduler.elm | 332 ++ src/Process.elm | 4 +- 14 files changed, 3791 insertions(+), 141 deletions(-) create mode 100644 design-documents/OperatorExample.elm create mode 100644 design-documents/elm-minimal-master/.gitignore create mode 100644 design-documents/elm-minimal-master/elm.json create mode 100644 design-documents/elm-minimal-master/main.js create mode 100644 design-documents/elm-minimal-master/src/Main.elm create mode 120000 design-documents/elm-minimal-master/src/OperatorExample.elm create mode 100644 design-documents/operators.md create mode 100644 design-documents/table.html create mode 100644 src/Platform/Scheduler.elm diff --git a/design-documents/OperatorExample.elm b/design-documents/OperatorExample.elm new file mode 100644 index 00000000..f544a9e0 --- /dev/null +++ b/design-documents/OperatorExample.elm @@ -0,0 +1,33 @@ +module OperatorExample exposing (..) + +import Platform + + +compositionExample : (Float -> Float -> Float) +compositionExample x = + mean 6 + >> mean x + + +mean : Float -> Float -> Float +mean a b = + (a + b) / 2 + + +ident : Bool -> Bool +ident b = + not (not b) + + +main = + let + m = compositionExample 21 4 + + _ = ident True + in + + Platform.worker + { init = \() -> (m, Cmd.none) + , update = \model _ -> (model, Cmd.none) + , subscriptions = \_ -> Sub.none + } diff --git a/design-documents/elm-minimal-master/.gitignore b/design-documents/elm-minimal-master/.gitignore new file mode 100644 index 00000000..aee98106 --- /dev/null +++ b/design-documents/elm-minimal-master/.gitignore @@ -0,0 +1 @@ +/elm-stuff/ diff --git a/design-documents/elm-minimal-master/elm.json b/design-documents/elm-minimal-master/elm.json new file mode 100644 index 00000000..fd754fc7 --- /dev/null +++ b/design-documents/elm-minimal-master/elm.json @@ -0,0 +1,24 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "elm/browser": "1.0.1", + "elm/core": "1.0.2", + "elm/html": "1.0.0" + }, + "indirect": { + "elm/json": "1.1.3", + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.2" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} diff --git a/design-documents/elm-minimal-master/main.js b/design-documents/elm-minimal-master/main.js new file mode 100644 index 00000000..a99c5992 --- /dev/null +++ b/design-documents/elm-minimal-master/main.js @@ -0,0 +1,2832 @@ +(function(scope){ +'use strict'; + +function F(arity, fun, wrapper) { + wrapper.a = arity; + wrapper.f = fun; + return wrapper; +} + +function F2(fun) { + return F(2, fun, function(a) { return function(b) { return fun(a,b); }; }) +} +function F3(fun) { + return F(3, fun, function(a) { + return function(b) { return function(c) { return fun(a, b, c); }; }; + }); +} +function F4(fun) { + return F(4, fun, function(a) { return function(b) { return function(c) { + return function(d) { return fun(a, b, c, d); }; }; }; + }); +} +function F5(fun) { + return F(5, fun, function(a) { return function(b) { return function(c) { + return function(d) { return function(e) { return fun(a, b, c, d, e); }; }; }; }; + }); +} +function F6(fun) { + return F(6, fun, function(a) { return function(b) { return function(c) { + return function(d) { return function(e) { return function(f) { + return fun(a, b, c, d, e, f); }; }; }; }; }; + }); +} +function F7(fun) { + return F(7, fun, function(a) { return function(b) { return function(c) { + return function(d) { return function(e) { return function(f) { + return function(g) { return fun(a, b, c, d, e, f, g); }; }; }; }; }; }; + }); +} +function F8(fun) { + return F(8, fun, function(a) { return function(b) { return function(c) { + return function(d) { return function(e) { return function(f) { + return function(g) { return function(h) { + return fun(a, b, c, d, e, f, g, h); }; }; }; }; }; }; }; + }); +} +function F9(fun) { + return F(9, fun, function(a) { return function(b) { return function(c) { + return function(d) { return function(e) { return function(f) { + return function(g) { return function(h) { return function(i) { + return fun(a, b, c, d, e, f, g, h, i); }; }; }; }; }; }; }; }; + }); +} + +function A2(fun, a, b) { + return fun.a === 2 ? fun.f(a, b) : fun(a)(b); +} +function A3(fun, a, b, c) { + return fun.a === 3 ? fun.f(a, b, c) : fun(a)(b)(c); +} +function A4(fun, a, b, c, d) { + return fun.a === 4 ? fun.f(a, b, c, d) : fun(a)(b)(c)(d); +} +function A5(fun, a, b, c, d, e) { + return fun.a === 5 ? fun.f(a, b, c, d, e) : fun(a)(b)(c)(d)(e); +} +function A6(fun, a, b, c, d, e, f) { + return fun.a === 6 ? fun.f(a, b, c, d, e, f) : fun(a)(b)(c)(d)(e)(f); +} +function A7(fun, a, b, c, d, e, f, g) { + return fun.a === 7 ? fun.f(a, b, c, d, e, f, g) : fun(a)(b)(c)(d)(e)(f)(g); +} +function A8(fun, a, b, c, d, e, f, g, h) { + return fun.a === 8 ? fun.f(a, b, c, d, e, f, g, h) : fun(a)(b)(c)(d)(e)(f)(g)(h); +} +function A9(fun, a, b, c, d, e, f, g, h, i) { + return fun.a === 9 ? fun.f(a, b, c, d, e, f, g, h, i) : fun(a)(b)(c)(d)(e)(f)(g)(h)(i); +} + +console.warn('Compiled in DEV mode. Follow the advice at https://elm-lang.org/0.19.1/optimize for better performance and smaller assets.'); + + +var _List_Nil_UNUSED = { $: 0 }; +var _List_Nil = { $: '[]' }; + +function _List_Cons_UNUSED(hd, tl) { return { $: 1, a: hd, b: tl }; } +function _List_Cons(hd, tl) { return { $: '::', a: hd, b: tl }; } + + +var _List_cons = F2(_List_Cons); + +function _List_fromArray(arr) +{ + var out = _List_Nil; + for (var i = arr.length; i--; ) + { + out = _List_Cons(arr[i], out); + } + return out; +} + +function _List_toArray(xs) +{ + for (var out = []; xs.b; xs = xs.b) // WHILE_CONS + { + out.push(xs.a); + } + return out; +} + +var _List_map2 = F3(function(f, xs, ys) +{ + for (var arr = []; xs.b && ys.b; xs = xs.b, ys = ys.b) // WHILE_CONSES + { + arr.push(A2(f, xs.a, ys.a)); + } + return _List_fromArray(arr); +}); + +var _List_map3 = F4(function(f, xs, ys, zs) +{ + for (var arr = []; xs.b && ys.b && zs.b; xs = xs.b, ys = ys.b, zs = zs.b) // WHILE_CONSES + { + arr.push(A3(f, xs.a, ys.a, zs.a)); + } + return _List_fromArray(arr); +}); + +var _List_map4 = F5(function(f, ws, xs, ys, zs) +{ + for (var arr = []; ws.b && xs.b && ys.b && zs.b; ws = ws.b, xs = xs.b, ys = ys.b, zs = zs.b) // WHILE_CONSES + { + arr.push(A4(f, ws.a, xs.a, ys.a, zs.a)); + } + return _List_fromArray(arr); +}); + +var _List_map5 = F6(function(f, vs, ws, xs, ys, zs) +{ + for (var arr = []; vs.b && ws.b && xs.b && ys.b && zs.b; vs = vs.b, ws = ws.b, xs = xs.b, ys = ys.b, zs = zs.b) // WHILE_CONSES + { + arr.push(A5(f, vs.a, ws.a, xs.a, ys.a, zs.a)); + } + return _List_fromArray(arr); +}); + +var _List_sortBy = F2(function(f, xs) +{ + return _List_fromArray(_List_toArray(xs).sort(function(a, b) { + return _Utils_cmp(f(a), f(b)); + })); +}); + +var _List_sortWith = F2(function(f, xs) +{ + return _List_fromArray(_List_toArray(xs).sort(function(a, b) { + var ord = A2(f, a, b); + return ord === $elm$core$Basics$EQ ? 0 : ord === $elm$core$Basics$LT ? -1 : 1; + })); +}); + + + +var _JsArray_empty = []; + +function _JsArray_singleton(value) +{ + return [value]; +} + +function _JsArray_length(array) +{ + return array.length; +} + +var _JsArray_initialize = F3(function(size, offset, func) +{ + var result = new Array(size); + + for (var i = 0; i < size; i++) + { + result[i] = func(offset + i); + } + + return result; +}); + +var _JsArray_initializeFromList = F2(function (max, ls) +{ + var result = new Array(max); + + for (var i = 0; i < max && ls.b; i++) + { + result[i] = ls.a; + ls = ls.b; + } + + result.length = i; + return _Utils_Tuple2(result, ls); +}); + +var _JsArray_unsafeGet = F2(function(index, array) +{ + return array[index]; +}); + +var _JsArray_unsafeSet = F3(function(index, value, array) +{ + var length = array.length; + var result = new Array(length); + + for (var i = 0; i < length; i++) + { + result[i] = array[i]; + } + + result[index] = value; + return result; +}); + +var _JsArray_push = F2(function(value, array) +{ + var length = array.length; + var result = new Array(length + 1); + + for (var i = 0; i < length; i++) + { + result[i] = array[i]; + } + + result[length] = value; + return result; +}); + +var _JsArray_foldl = F3(function(func, acc, array) +{ + var length = array.length; + + for (var i = 0; i < length; i++) + { + acc = A2(func, array[i], acc); + } + + return acc; +}); + +var _JsArray_foldr = F3(function(func, acc, array) +{ + for (var i = array.length - 1; i >= 0; i--) + { + acc = A2(func, array[i], acc); + } + + return acc; +}); + +var _JsArray_map = F2(function(func, array) +{ + var length = array.length; + var result = new Array(length); + + for (var i = 0; i < length; i++) + { + result[i] = func(array[i]); + } + + return result; +}); + +var _JsArray_indexedMap = F3(function(func, offset, array) +{ + var length = array.length; + var result = new Array(length); + + for (var i = 0; i < length; i++) + { + result[i] = A2(func, offset + i, array[i]); + } + + return result; +}); + +var _JsArray_slice = F3(function(from, to, array) +{ + return array.slice(from, to); +}); + +var _JsArray_appendN = F3(function(n, dest, source) +{ + var destLen = dest.length; + var itemsToCopy = n - destLen; + + if (itemsToCopy > source.length) + { + itemsToCopy = source.length; + } + + var size = destLen + itemsToCopy; + var result = new Array(size); + + for (var i = 0; i < destLen; i++) + { + result[i] = dest[i]; + } + + for (var i = 0; i < itemsToCopy; i++) + { + result[i + destLen] = source[i]; + } + + return result; +}); + + + +// LOG + +var _Debug_log_UNUSED = F2(function(tag, value) +{ + return value; +}); + +var _Debug_log = F2(function(tag, value) +{ + console.log(tag + ': ' + _Debug_toString(value)); + return value; +}); + + +// TODOS + +function _Debug_todo(moduleName, region) +{ + return function(message) { + _Debug_crash(8, moduleName, region, message); + }; +} + +function _Debug_todoCase(moduleName, region, value) +{ + return function(message) { + _Debug_crash(9, moduleName, region, value, message); + }; +} + + +// TO STRING + +function _Debug_toString_UNUSED(value) +{ + return ''; +} + +function _Debug_toString(value) +{ + return _Debug_toAnsiString(false, value); +} + +function _Debug_toAnsiString(ansi, value) +{ + if (typeof value === 'function') + { + return _Debug_internalColor(ansi, ''); + } + + if (typeof value === 'boolean') + { + return _Debug_ctorColor(ansi, value ? 'True' : 'False'); + } + + if (typeof value === 'number') + { + return _Debug_numberColor(ansi, value + ''); + } + + if (value instanceof String) + { + return _Debug_charColor(ansi, "'" + _Debug_addSlashes(value, true) + "'"); + } + + if (typeof value === 'string') + { + return _Debug_stringColor(ansi, '"' + _Debug_addSlashes(value, false) + '"'); + } + + if (typeof value === 'object' && '$' in value) + { + var tag = value.$; + + if (typeof tag === 'number') + { + return _Debug_internalColor(ansi, ''); + } + + if (tag[0] === '#') + { + var output = []; + for (var k in value) + { + if (k === '$') continue; + output.push(_Debug_toAnsiString(ansi, value[k])); + } + return '(' + output.join(',') + ')'; + } + + if (tag === 'Set_elm_builtin') + { + return _Debug_ctorColor(ansi, 'Set') + + _Debug_fadeColor(ansi, '.fromList') + ' ' + + _Debug_toAnsiString(ansi, $elm$core$Set$toList(value)); + } + + if (tag === 'RBNode_elm_builtin' || tag === 'RBEmpty_elm_builtin') + { + return _Debug_ctorColor(ansi, 'Dict') + + _Debug_fadeColor(ansi, '.fromList') + ' ' + + _Debug_toAnsiString(ansi, $elm$core$Dict$toList(value)); + } + + if (tag === 'Array_elm_builtin') + { + return _Debug_ctorColor(ansi, 'Array') + + _Debug_fadeColor(ansi, '.fromList') + ' ' + + _Debug_toAnsiString(ansi, $elm$core$Array$toList(value)); + } + + if (tag === '::' || tag === '[]') + { + var output = '['; + + value.b && (output += _Debug_toAnsiString(ansi, value.a), value = value.b) + + for (; value.b; value = value.b) // WHILE_CONS + { + output += ',' + _Debug_toAnsiString(ansi, value.a); + } + return output + ']'; + } + + var output = ''; + for (var i in value) + { + if (i === '$') continue; + var str = _Debug_toAnsiString(ansi, value[i]); + var c0 = str[0]; + var parenless = c0 === '{' || c0 === '(' || c0 === '[' || c0 === '<' || c0 === '"' || str.indexOf(' ') < 0; + output += ' ' + (parenless ? str : '(' + str + ')'); + } + return _Debug_ctorColor(ansi, tag) + output; + } + + if (typeof DataView === 'function' && value instanceof DataView) + { + return _Debug_stringColor(ansi, '<' + value.byteLength + ' bytes>'); + } + + if (typeof File === 'function' && value instanceof File) + { + return _Debug_internalColor(ansi, '<' + value.name + '>'); + } + + if (typeof value === 'object') + { + var output = []; + for (var key in value) + { + var field = key[0] === '_' ? key.slice(1) : key; + output.push(_Debug_fadeColor(ansi, field) + ' = ' + _Debug_toAnsiString(ansi, value[key])); + } + if (output.length === 0) + { + return '{}'; + } + return '{ ' + output.join(', ') + ' }'; + } + + return _Debug_internalColor(ansi, ''); +} + +function _Debug_addSlashes(str, isChar) +{ + var s = str + .replace(/\\/g, '\\\\') + .replace(/\n/g, '\\n') + .replace(/\t/g, '\\t') + .replace(/\r/g, '\\r') + .replace(/\v/g, '\\v') + .replace(/\0/g, '\\0'); + + if (isChar) + { + return s.replace(/\'/g, '\\\''); + } + else + { + return s.replace(/\"/g, '\\"'); + } +} + +function _Debug_ctorColor(ansi, string) +{ + return ansi ? '\x1b[96m' + string + '\x1b[0m' : string; +} + +function _Debug_numberColor(ansi, string) +{ + return ansi ? '\x1b[95m' + string + '\x1b[0m' : string; +} + +function _Debug_stringColor(ansi, string) +{ + return ansi ? '\x1b[93m' + string + '\x1b[0m' : string; +} + +function _Debug_charColor(ansi, string) +{ + return ansi ? '\x1b[92m' + string + '\x1b[0m' : string; +} + +function _Debug_fadeColor(ansi, string) +{ + return ansi ? '\x1b[37m' + string + '\x1b[0m' : string; +} + +function _Debug_internalColor(ansi, string) +{ + return ansi ? '\x1b[94m' + string + '\x1b[0m' : string; +} + +function _Debug_toHexDigit(n) +{ + return String.fromCharCode(n < 10 ? 48 + n : 55 + n); +} + + +// CRASH + + +function _Debug_crash_UNUSED(identifier) +{ + throw new Error('https://github.com/elm/core/blob/1.0.0/hints/' + identifier + '.md'); +} + + +function _Debug_crash(identifier, fact1, fact2, fact3, fact4) +{ + switch(identifier) + { + case 0: + throw new Error('What node should I take over? In JavaScript I need something like:\n\n Elm.Main.init({\n node: document.getElementById("elm-node")\n })\n\nYou need to do this with any Browser.sandbox or Browser.element program.'); + + case 1: + throw new Error('Browser.application programs cannot handle URLs like this:\n\n ' + document.location.href + '\n\nWhat is the root? The root of your file system? Try looking at this program with `elm reactor` or some other server.'); + + case 2: + var jsonErrorString = fact1; + throw new Error('Problem with the flags given to your Elm program on initialization.\n\n' + jsonErrorString); + + case 3: + var portName = fact1; + throw new Error('There can only be one port named `' + portName + '`, but your program has multiple.'); + + case 4: + var portName = fact1; + var problem = fact2; + throw new Error('Trying to send an unexpected type of value through port `' + portName + '`:\n' + problem); + + case 5: + throw new Error('Trying to use `(==)` on functions.\nThere is no way to know if functions are "the same" in the Elm sense.\nRead more about this at https://package.elm-lang.org/packages/elm/core/latest/Basics#== which describes why it is this way and what the better version will look like.'); + + case 6: + var moduleName = fact1; + throw new Error('Your page is loading multiple Elm scripts with a module named ' + moduleName + '. Maybe a duplicate script is getting loaded accidentally? If not, rename one of them so I know which is which!'); + + case 8: + var moduleName = fact1; + var region = fact2; + var message = fact3; + throw new Error('TODO in module `' + moduleName + '` ' + _Debug_regionToString(region) + '\n\n' + message); + + case 9: + var moduleName = fact1; + var region = fact2; + var value = fact3; + var message = fact4; + throw new Error( + 'TODO in module `' + moduleName + '` from the `case` expression ' + + _Debug_regionToString(region) + '\n\nIt received the following value:\n\n ' + + _Debug_toString(value).replace('\n', '\n ') + + '\n\nBut the branch that handles it says:\n\n ' + message.replace('\n', '\n ') + ); + + case 10: + throw new Error('Bug in https://github.com/elm/virtual-dom/issues'); + + case 11: + throw new Error('Cannot perform mod 0. Division by zero error.'); + } +} + +function _Debug_regionToString(region) +{ + if (region.start.line === region.end.line) + { + return 'on line ' + region.start.line; + } + return 'on lines ' + region.start.line + ' through ' + region.end.line; +} + + + +// EQUALITY + +function _Utils_eq(x, y) +{ + for ( + var pair, stack = [], isEqual = _Utils_eqHelp(x, y, 0, stack); + isEqual && (pair = stack.pop()); + isEqual = _Utils_eqHelp(pair.a, pair.b, 0, stack) + ) + {} + + return isEqual; +} + +function _Utils_eqHelp(x, y, depth, stack) +{ + if (depth > 100) + { + stack.push(_Utils_Tuple2(x,y)); + return true; + } + + if (x === y) + { + return true; + } + + if (typeof x !== 'object' || x === null || y === null) + { + typeof x === 'function' && _Debug_crash(5); + return false; + } + + /**/ + if (x.$ === 'Set_elm_builtin') + { + x = $elm$core$Set$toList(x); + y = $elm$core$Set$toList(y); + } + if (x.$ === 'RBNode_elm_builtin' || x.$ === 'RBEmpty_elm_builtin') + { + x = $elm$core$Dict$toList(x); + y = $elm$core$Dict$toList(y); + } + //*/ + + /**_UNUSED/ + if (x.$ < 0) + { + x = $elm$core$Dict$toList(x); + y = $elm$core$Dict$toList(y); + } + //*/ + + for (var key in x) + { + if (!_Utils_eqHelp(x[key], y[key], depth + 1, stack)) + { + return false; + } + } + return true; +} + +var _Utils_equal = F2(_Utils_eq); +var _Utils_notEqual = F2(function(a, b) { return !_Utils_eq(a,b); }); + + + +// COMPARISONS + +// Code in Generate/JavaScript.hs, Basics.js, and List.js depends on +// the particular integer values assigned to LT, EQ, and GT. + +function _Utils_cmp(x, y, ord) +{ + if (typeof x !== 'object') + { + return x === y ? /*EQ*/ 0 : x < y ? /*LT*/ -1 : /*GT*/ 1; + } + + /**/ + if (x instanceof String) + { + var a = x.valueOf(); + var b = y.valueOf(); + return a === b ? 0 : a < b ? -1 : 1; + } + //*/ + + /**_UNUSED/ + if (typeof x.$ === 'undefined') + //*/ + /**/ + if (x.$[0] === '#') + //*/ + { + return (ord = _Utils_cmp(x.a, y.a)) + ? ord + : (ord = _Utils_cmp(x.b, y.b)) + ? ord + : _Utils_cmp(x.c, y.c); + } + + // traverse conses until end of a list or a mismatch + for (; x.b && y.b && !(ord = _Utils_cmp(x.a, y.a)); x = x.b, y = y.b) {} // WHILE_CONSES + return ord || (x.b ? /*GT*/ 1 : y.b ? /*LT*/ -1 : /*EQ*/ 0); +} + +var _Utils_lt = F2(function(a, b) { return _Utils_cmp(a, b) < 0; }); +var _Utils_le = F2(function(a, b) { return _Utils_cmp(a, b) < 1; }); +var _Utils_gt = F2(function(a, b) { return _Utils_cmp(a, b) > 0; }); +var _Utils_ge = F2(function(a, b) { return _Utils_cmp(a, b) >= 0; }); + +var _Utils_compare = F2(function(x, y) +{ + var n = _Utils_cmp(x, y); + return n < 0 ? $elm$core$Basics$LT : n ? $elm$core$Basics$GT : $elm$core$Basics$EQ; +}); + + +// COMMON VALUES + +var _Utils_Tuple0_UNUSED = 0; +var _Utils_Tuple0 = { $: '#0' }; + +function _Utils_Tuple2_UNUSED(a, b) { return { a: a, b: b }; } +function _Utils_Tuple2(a, b) { return { $: '#2', a: a, b: b }; } + +function _Utils_Tuple3_UNUSED(a, b, c) { return { a: a, b: b, c: c }; } +function _Utils_Tuple3(a, b, c) { return { $: '#3', a: a, b: b, c: c }; } + +function _Utils_chr_UNUSED(c) { return c; } +function _Utils_chr(c) { return new String(c); } + + +// RECORDS + +function _Utils_update(oldRecord, updatedFields) +{ + var newRecord = {}; + + for (var key in oldRecord) + { + newRecord[key] = oldRecord[key]; + } + + for (var key in updatedFields) + { + newRecord[key] = updatedFields[key]; + } + + return newRecord; +} + + +// APPEND + +var _Utils_append = F2(_Utils_ap); + +function _Utils_ap(xs, ys) +{ + // append Strings + if (typeof xs === 'string') + { + return xs + ys; + } + + // append Lists + if (!xs.b) + { + return ys; + } + var root = _List_Cons(xs.a, ys); + xs = xs.b + for (var curr = root; xs.b; xs = xs.b) // WHILE_CONS + { + curr = curr.b = _List_Cons(xs.a, ys); + } + return root; +} + + + +// MATH + +var _Basics_add = F2(function(a, b) { return a + b; }); +var _Basics_sub = F2(function(a, b) { return a - b; }); +var _Basics_mul = F2(function(a, b) { return a * b; }); +var _Basics_fdiv = F2(function(a, b) { return a / b; }); +var _Basics_idiv = F2(function(a, b) { return (a / b) | 0; }); +var _Basics_pow = F2(Math.pow); + +var _Basics_remainderBy = F2(function(b, a) { return a % b; }); + +// https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf +var _Basics_modBy = F2(function(modulus, x) +{ + var answer = x % modulus; + return modulus === 0 + ? _Debug_crash(11) + : + ((answer > 0 && modulus < 0) || (answer < 0 && modulus > 0)) + ? answer + modulus + : answer; +}); + + +// TRIGONOMETRY + +var _Basics_pi = Math.PI; +var _Basics_e = Math.E; +var _Basics_cos = Math.cos; +var _Basics_sin = Math.sin; +var _Basics_tan = Math.tan; +var _Basics_acos = Math.acos; +var _Basics_asin = Math.asin; +var _Basics_atan = Math.atan; +var _Basics_atan2 = F2(Math.atan2); + + +// MORE MATH + +function _Basics_toFloat(x) { return x; } +function _Basics_truncate(n) { return n | 0; } +function _Basics_isInfinite(n) { return n === Infinity || n === -Infinity; } + +var _Basics_ceiling = Math.ceil; +var _Basics_floor = Math.floor; +var _Basics_round = Math.round; +var _Basics_sqrt = Math.sqrt; +var _Basics_log = Math.log; +var _Basics_isNaN = isNaN; + + +// BOOLEANS + +function _Basics_not(bool) { return !bool; } +var _Basics_and = F2(function(a, b) { return a && b; }); +var _Basics_or = F2(function(a, b) { return a || b; }); +var _Basics_xor = F2(function(a, b) { return a !== b; }); + + + +var _String_cons = F2(function(chr, str) +{ + return chr + str; +}); + +function _String_uncons(string) +{ + var word = string.charCodeAt(0); + return word + ? $elm$core$Maybe$Just( + 0xD800 <= word && word <= 0xDBFF + ? _Utils_Tuple2(_Utils_chr(string[0] + string[1]), string.slice(2)) + : _Utils_Tuple2(_Utils_chr(string[0]), string.slice(1)) + ) + : $elm$core$Maybe$Nothing; +} + +var _String_append = F2(function(a, b) +{ + return a + b; +}); + +function _String_length(str) +{ + return str.length; +} + +var _String_map = F2(function(func, string) +{ + var len = string.length; + var array = new Array(len); + var i = 0; + while (i < len) + { + var word = string.charCodeAt(i); + if (0xD800 <= word && word <= 0xDBFF) + { + array[i] = func(_Utils_chr(string[i] + string[i+1])); + i += 2; + continue; + } + array[i] = func(_Utils_chr(string[i])); + i++; + } + return array.join(''); +}); + +var _String_filter = F2(function(isGood, str) +{ + var arr = []; + var len = str.length; + var i = 0; + while (i < len) + { + var char = str[i]; + var word = str.charCodeAt(i); + i++; + if (0xD800 <= word && word <= 0xDBFF) + { + char += str[i]; + i++; + } + + if (isGood(_Utils_chr(char))) + { + arr.push(char); + } + } + return arr.join(''); +}); + +function _String_reverse(str) +{ + var len = str.length; + var arr = new Array(len); + var i = 0; + while (i < len) + { + var word = str.charCodeAt(i); + if (0xD800 <= word && word <= 0xDBFF) + { + arr[len - i] = str[i + 1]; + i++; + arr[len - i] = str[i - 1]; + i++; + } + else + { + arr[len - i] = str[i]; + i++; + } + } + return arr.join(''); +} + +var _String_foldl = F3(function(func, state, string) +{ + var len = string.length; + var i = 0; + while (i < len) + { + var char = string[i]; + var word = string.charCodeAt(i); + i++; + if (0xD800 <= word && word <= 0xDBFF) + { + char += string[i]; + i++; + } + state = A2(func, _Utils_chr(char), state); + } + return state; +}); + +var _String_foldr = F3(function(func, state, string) +{ + var i = string.length; + while (i--) + { + var char = string[i]; + var word = string.charCodeAt(i); + if (0xDC00 <= word && word <= 0xDFFF) + { + i--; + char = string[i] + char; + } + state = A2(func, _Utils_chr(char), state); + } + return state; +}); + +var _String_split = F2(function(sep, str) +{ + return str.split(sep); +}); + +var _String_join = F2(function(sep, strs) +{ + return strs.join(sep); +}); + +var _String_slice = F3(function(start, end, str) { + return str.slice(start, end); +}); + +function _String_trim(str) +{ + return str.trim(); +} + +function _String_trimLeft(str) +{ + return str.replace(/^\s+/, ''); +} + +function _String_trimRight(str) +{ + return str.replace(/\s+$/, ''); +} + +function _String_words(str) +{ + return _List_fromArray(str.trim().split(/\s+/g)); +} + +function _String_lines(str) +{ + return _List_fromArray(str.split(/\r\n|\r|\n/g)); +} + +function _String_toUpper(str) +{ + return str.toUpperCase(); +} + +function _String_toLower(str) +{ + return str.toLowerCase(); +} + +var _String_any = F2(function(isGood, string) +{ + var i = string.length; + while (i--) + { + var char = string[i]; + var word = string.charCodeAt(i); + if (0xDC00 <= word && word <= 0xDFFF) + { + i--; + char = string[i] + char; + } + if (isGood(_Utils_chr(char))) + { + return true; + } + } + return false; +}); + +var _String_all = F2(function(isGood, string) +{ + var i = string.length; + while (i--) + { + var char = string[i]; + var word = string.charCodeAt(i); + if (0xDC00 <= word && word <= 0xDFFF) + { + i--; + char = string[i] + char; + } + if (!isGood(_Utils_chr(char))) + { + return false; + } + } + return true; +}); + +var _String_contains = F2(function(sub, str) +{ + return str.indexOf(sub) > -1; +}); + +var _String_startsWith = F2(function(sub, str) +{ + return str.indexOf(sub) === 0; +}); + +var _String_endsWith = F2(function(sub, str) +{ + return str.length >= sub.length && + str.lastIndexOf(sub) === str.length - sub.length; +}); + +var _String_indexes = F2(function(sub, str) +{ + var subLen = sub.length; + + if (subLen < 1) + { + return _List_Nil; + } + + var i = 0; + var is = []; + + while ((i = str.indexOf(sub, i)) > -1) + { + is.push(i); + i = i + subLen; + } + + return _List_fromArray(is); +}); + + +// TO STRING + +function _String_fromNumber(number) +{ + return number + ''; +} + + +// INT CONVERSIONS + +function _String_toInt(str) +{ + var total = 0; + var code0 = str.charCodeAt(0); + var start = code0 == 0x2B /* + */ || code0 == 0x2D /* - */ ? 1 : 0; + + for (var i = start; i < str.length; ++i) + { + var code = str.charCodeAt(i); + if (code < 0x30 || 0x39 < code) + { + return $elm$core$Maybe$Nothing; + } + total = 10 * total + code - 0x30; + } + + return i == start + ? $elm$core$Maybe$Nothing + : $elm$core$Maybe$Just(code0 == 0x2D ? -total : total); +} + + +// FLOAT CONVERSIONS + +function _String_toFloat(s) +{ + // check if it is a hex, octal, or binary number + if (s.length === 0 || /[\sxbo]/.test(s)) + { + return $elm$core$Maybe$Nothing; + } + var n = +s; + // faster isNaN check + return n === n ? $elm$core$Maybe$Just(n) : $elm$core$Maybe$Nothing; +} + +function _String_fromList(chars) +{ + return _List_toArray(chars).join(''); +} + + + + +function _Char_toCode(char) +{ + var code = char.charCodeAt(0); + if (0xD800 <= code && code <= 0xDBFF) + { + return (code - 0xD800) * 0x400 + char.charCodeAt(1) - 0xDC00 + 0x10000 + } + return code; +} + +function _Char_fromCode(code) +{ + return _Utils_chr( + (code < 0 || 0x10FFFF < code) + ? '\uFFFD' + : + (code <= 0xFFFF) + ? String.fromCharCode(code) + : + (code -= 0x10000, + String.fromCharCode(Math.floor(code / 0x400) + 0xD800, code % 0x400 + 0xDC00) + ) + ); +} + +function _Char_toUpper(char) +{ + return _Utils_chr(char.toUpperCase()); +} + +function _Char_toLower(char) +{ + return _Utils_chr(char.toLowerCase()); +} + +function _Char_toLocaleUpper(char) +{ + return _Utils_chr(char.toLocaleUpperCase()); +} + +function _Char_toLocaleLower(char) +{ + return _Utils_chr(char.toLocaleLowerCase()); +} + + + +/**/ +function _Json_errorToString(error) +{ + return $elm$json$Json$Decode$errorToString(error); +} +//*/ + + +// CORE DECODERS + +function _Json_succeed(msg) +{ + return { + $: 0, + a: msg + }; +} + +function _Json_fail(msg) +{ + return { + $: 1, + a: msg + }; +} + +function _Json_decodePrim(decoder) +{ + return { $: 2, b: decoder }; +} + +var _Json_decodeInt = _Json_decodePrim(function(value) { + return (typeof value !== 'number') + ? _Json_expecting('an INT', value) + : + (-2147483647 < value && value < 2147483647 && (value | 0) === value) + ? $elm$core$Result$Ok(value) + : + (isFinite(value) && !(value % 1)) + ? $elm$core$Result$Ok(value) + : _Json_expecting('an INT', value); +}); + +var _Json_decodeBool = _Json_decodePrim(function(value) { + return (typeof value === 'boolean') + ? $elm$core$Result$Ok(value) + : _Json_expecting('a BOOL', value); +}); + +var _Json_decodeFloat = _Json_decodePrim(function(value) { + return (typeof value === 'number') + ? $elm$core$Result$Ok(value) + : _Json_expecting('a FLOAT', value); +}); + +var _Json_decodeValue = _Json_decodePrim(function(value) { + return $elm$core$Result$Ok(_Json_wrap(value)); +}); + +var _Json_decodeString = _Json_decodePrim(function(value) { + return (typeof value === 'string') + ? $elm$core$Result$Ok(value) + : (value instanceof String) + ? $elm$core$Result$Ok(value + '') + : _Json_expecting('a STRING', value); +}); + +function _Json_decodeList(decoder) { return { $: 3, b: decoder }; } +function _Json_decodeArray(decoder) { return { $: 4, b: decoder }; } + +function _Json_decodeNull(value) { return { $: 5, c: value }; } + +var _Json_decodeField = F2(function(field, decoder) +{ + return { + $: 6, + d: field, + b: decoder + }; +}); + +var _Json_decodeIndex = F2(function(index, decoder) +{ + return { + $: 7, + e: index, + b: decoder + }; +}); + +function _Json_decodeKeyValuePairs(decoder) +{ + return { + $: 8, + b: decoder + }; +} + +function _Json_mapMany(f, decoders) +{ + return { + $: 9, + f: f, + g: decoders + }; +} + +var _Json_andThen = F2(function(callback, decoder) +{ + return { + $: 10, + b: decoder, + h: callback + }; +}); + +function _Json_oneOf(decoders) +{ + return { + $: 11, + g: decoders + }; +} + + +// DECODING OBJECTS + +var _Json_map1 = F2(function(f, d1) +{ + return _Json_mapMany(f, [d1]); +}); + +var _Json_map2 = F3(function(f, d1, d2) +{ + return _Json_mapMany(f, [d1, d2]); +}); + +var _Json_map3 = F4(function(f, d1, d2, d3) +{ + return _Json_mapMany(f, [d1, d2, d3]); +}); + +var _Json_map4 = F5(function(f, d1, d2, d3, d4) +{ + return _Json_mapMany(f, [d1, d2, d3, d4]); +}); + +var _Json_map5 = F6(function(f, d1, d2, d3, d4, d5) +{ + return _Json_mapMany(f, [d1, d2, d3, d4, d5]); +}); + +var _Json_map6 = F7(function(f, d1, d2, d3, d4, d5, d6) +{ + return _Json_mapMany(f, [d1, d2, d3, d4, d5, d6]); +}); + +var _Json_map7 = F8(function(f, d1, d2, d3, d4, d5, d6, d7) +{ + return _Json_mapMany(f, [d1, d2, d3, d4, d5, d6, d7]); +}); + +var _Json_map8 = F9(function(f, d1, d2, d3, d4, d5, d6, d7, d8) +{ + return _Json_mapMany(f, [d1, d2, d3, d4, d5, d6, d7, d8]); +}); + + +// DECODE + +var _Json_runOnString = F2(function(decoder, string) +{ + try + { + var value = JSON.parse(string); + return _Json_runHelp(decoder, value); + } + catch (e) + { + return $elm$core$Result$Err(A2($elm$json$Json$Decode$Failure, 'This is not valid JSON! ' + e.message, _Json_wrap(string))); + } +}); + +var _Json_run = F2(function(decoder, value) +{ + return _Json_runHelp(decoder, _Json_unwrap(value)); +}); + +function _Json_runHelp(decoder, value) +{ + switch (decoder.$) + { + case 2: + return decoder.b(value); + + case 5: + return (value === null) + ? $elm$core$Result$Ok(decoder.c) + : _Json_expecting('null', value); + + case 3: + if (!_Json_isArray(value)) + { + return _Json_expecting('a LIST', value); + } + return _Json_runArrayDecoder(decoder.b, value, _List_fromArray); + + case 4: + if (!_Json_isArray(value)) + { + return _Json_expecting('an ARRAY', value); + } + return _Json_runArrayDecoder(decoder.b, value, _Json_toElmArray); + + case 6: + var field = decoder.d; + if (typeof value !== 'object' || value === null || !(field in value)) + { + return _Json_expecting('an OBJECT with a field named `' + field + '`', value); + } + var result = _Json_runHelp(decoder.b, value[field]); + return ($elm$core$Result$isOk(result)) ? result : $elm$core$Result$Err(A2($elm$json$Json$Decode$Field, field, result.a)); + + case 7: + var index = decoder.e; + if (!_Json_isArray(value)) + { + return _Json_expecting('an ARRAY', value); + } + if (index >= value.length) + { + return _Json_expecting('a LONGER array. Need index ' + index + ' but only see ' + value.length + ' entries', value); + } + var result = _Json_runHelp(decoder.b, value[index]); + return ($elm$core$Result$isOk(result)) ? result : $elm$core$Result$Err(A2($elm$json$Json$Decode$Index, index, result.a)); + + case 8: + if (typeof value !== 'object' || value === null || _Json_isArray(value)) + { + return _Json_expecting('an OBJECT', value); + } + + var keyValuePairs = _List_Nil; + // TODO test perf of Object.keys and switch when support is good enough + for (var key in value) + { + if (value.hasOwnProperty(key)) + { + var result = _Json_runHelp(decoder.b, value[key]); + if (!$elm$core$Result$isOk(result)) + { + return $elm$core$Result$Err(A2($elm$json$Json$Decode$Field, key, result.a)); + } + keyValuePairs = _List_Cons(_Utils_Tuple2(key, result.a), keyValuePairs); + } + } + return $elm$core$Result$Ok($elm$core$List$reverse(keyValuePairs)); + + case 9: + var answer = decoder.f; + var decoders = decoder.g; + for (var i = 0; i < decoders.length; i++) + { + var result = _Json_runHelp(decoders[i], value); + if (!$elm$core$Result$isOk(result)) + { + return result; + } + answer = answer(result.a); + } + return $elm$core$Result$Ok(answer); + + case 10: + var result = _Json_runHelp(decoder.b, value); + return (!$elm$core$Result$isOk(result)) + ? result + : _Json_runHelp(decoder.h(result.a), value); + + case 11: + var errors = _List_Nil; + for (var temp = decoder.g; temp.b; temp = temp.b) // WHILE_CONS + { + var result = _Json_runHelp(temp.a, value); + if ($elm$core$Result$isOk(result)) + { + return result; + } + errors = _List_Cons(result.a, errors); + } + return $elm$core$Result$Err($elm$json$Json$Decode$OneOf($elm$core$List$reverse(errors))); + + case 1: + return $elm$core$Result$Err(A2($elm$json$Json$Decode$Failure, decoder.a, _Json_wrap(value))); + + case 0: + return $elm$core$Result$Ok(decoder.a); + } +} + +function _Json_runArrayDecoder(decoder, value, toElmValue) +{ + var len = value.length; + var array = new Array(len); + for (var i = 0; i < len; i++) + { + var result = _Json_runHelp(decoder, value[i]); + if (!$elm$core$Result$isOk(result)) + { + return $elm$core$Result$Err(A2($elm$json$Json$Decode$Index, i, result.a)); + } + array[i] = result.a; + } + return $elm$core$Result$Ok(toElmValue(array)); +} + +function _Json_isArray(value) +{ + return Array.isArray(value) || (typeof FileList !== 'undefined' && value instanceof FileList); +} + +function _Json_toElmArray(array) +{ + return A2($elm$core$Array$initialize, array.length, function(i) { return array[i]; }); +} + +function _Json_expecting(type, value) +{ + return $elm$core$Result$Err(A2($elm$json$Json$Decode$Failure, 'Expecting ' + type, _Json_wrap(value))); +} + + +// EQUALITY + +function _Json_equality(x, y) +{ + if (x === y) + { + return true; + } + + if (x.$ !== y.$) + { + return false; + } + + switch (x.$) + { + case 0: + case 1: + return x.a === y.a; + + case 2: + return x.b === y.b; + + case 5: + return x.c === y.c; + + case 3: + case 4: + case 8: + return _Json_equality(x.b, y.b); + + case 6: + return x.d === y.d && _Json_equality(x.b, y.b); + + case 7: + return x.e === y.e && _Json_equality(x.b, y.b); + + case 9: + return x.f === y.f && _Json_listEquality(x.g, y.g); + + case 10: + return x.h === y.h && _Json_equality(x.b, y.b); + + case 11: + return _Json_listEquality(x.g, y.g); + } +} + +function _Json_listEquality(aDecoders, bDecoders) +{ + var len = aDecoders.length; + if (len !== bDecoders.length) + { + return false; + } + for (var i = 0; i < len; i++) + { + if (!_Json_equality(aDecoders[i], bDecoders[i])) + { + return false; + } + } + return true; +} + + +// ENCODE + +var _Json_encode = F2(function(indentLevel, value) +{ + return JSON.stringify(_Json_unwrap(value), null, indentLevel) + ''; +}); + +function _Json_wrap(value) { return { $: 0, a: value }; } +function _Json_unwrap(value) { return value.a; } + +function _Json_wrap_UNUSED(value) { return value; } +function _Json_unwrap_UNUSED(value) { return value; } + +function _Json_emptyArray() { return []; } +function _Json_emptyObject() { return {}; } + +var _Json_addField = F3(function(key, value, object) +{ + object[key] = _Json_unwrap(value); + return object; +}); + +function _Json_addEntry(func) +{ + return F2(function(entry, array) + { + array.push(_Json_unwrap(func(entry))); + return array; + }); +} + +var _Json_encodeNull = _Json_wrap(null); + + + +// TASKS + +function _Scheduler_succeed(value) +{ + return { + $: 0, + a: value + }; +} + +function _Scheduler_fail(error) +{ + return { + $: 1, + a: error + }; +} + +function _Scheduler_binding(callback) +{ + return { + $: 2, + b: callback, + c: null + }; +} + +var _Scheduler_andThen = F2(function(callback, task) +{ + return { + $: 3, + b: callback, + d: task + }; +}); + +var _Scheduler_onError = F2(function(callback, task) +{ + return { + $: 4, + b: callback, + d: task + }; +}); + +function _Scheduler_receive(callback) +{ + return { + $: 5, + b: callback + }; +} + + +// PROCESSES + +var _Scheduler_guid = 0; + +function _Scheduler_rawSpawn(task) +{ + var proc = { + $: 0, + e: _Scheduler_guid++, + f: task, + g: null, + h: [] + }; + + _Scheduler_enqueue(proc); + + return proc; +} + +function _Scheduler_spawn(task) +{ + return _Scheduler_binding(function(callback) { + callback(_Scheduler_succeed(_Scheduler_rawSpawn(task))); + }); +} + +function _Scheduler_rawSend(proc, msg) +{ + proc.h.push(msg); + _Scheduler_enqueue(proc); +} + +var _Scheduler_send = F2(function(proc, msg) +{ + return _Scheduler_binding(function(callback) { + _Scheduler_rawSend(proc, msg); + callback(_Scheduler_succeed(_Utils_Tuple0)); + }); +}); + +function _Scheduler_kill(proc) +{ + return _Scheduler_binding(function(callback) { + var task = proc.f; + if (task.$ === 2 && task.c) + { + task.c(); + } + + proc.f = null; + + callback(_Scheduler_succeed(_Utils_Tuple0)); + }); +} + + +/* STEP PROCESSES + +type alias Process = + { $ : tag + , id : unique_id + , root : Task + , stack : null | { $: SUCCEED | FAIL, a: callback, b: stack } + , mailbox : [msg] + } + +*/ + + +var _Scheduler_working = false; +var _Scheduler_queue = []; + + +function _Scheduler_enqueue(proc) +{ + _Scheduler_queue.push(proc); + if (_Scheduler_working) + { + return; + } + _Scheduler_working = true; + while (proc = _Scheduler_queue.shift()) + { + _Scheduler_step(proc); + } + _Scheduler_working = false; +} + + +function _Scheduler_step(proc) +{ + while (proc.f) + { + var rootTag = proc.f.$; + if (rootTag === 0 || rootTag === 1) + { + while (proc.g && proc.g.$ !== rootTag) + { + proc.g = proc.g.i; + } + if (!proc.g) + { + return; + } + proc.f = proc.g.b(proc.f.a); + proc.g = proc.g.i; + } + else if (rootTag === 2) + { + proc.f.c = proc.f.b(function(newRoot) { + proc.f = newRoot; + _Scheduler_enqueue(proc); + }); + return; + } + else if (rootTag === 5) + { + if (proc.h.length === 0) + { + return; + } + proc.f = proc.f.b(proc.h.shift()); + } + else // if (rootTag === 3 || rootTag === 4) + { + proc.g = { + $: rootTag === 3 ? 0 : 1, + b: proc.f.b, + i: proc.g + }; + proc.f = proc.f.d; + } + } +} + + + +function _Process_sleep(time) +{ + return _Scheduler_binding(function(callback) { + var id = setTimeout(function() { + callback(_Scheduler_succeed(_Utils_Tuple0)); + }, time); + + return function() { clearTimeout(id); }; + }); +} + + + + +// PROGRAMS + + +var _Platform_worker = F4(function(impl, flagDecoder, debugMetadata, args) +{ + return _Platform_initialize( + flagDecoder, + args, + impl.init, + impl.update, + impl.subscriptions, + function() { return function() {} } + ); +}); + + + +// INITIALIZE A PROGRAM + + +function _Platform_initialize(flagDecoder, args, init, update, subscriptions, stepperBuilder) +{ + var result = A2(_Json_run, flagDecoder, _Json_wrap(args ? args['flags'] : undefined)); + $elm$core$Result$isOk(result) || _Debug_crash(2 /**/, _Json_errorToString(result.a) /**/); + var managers = {}; + result = init(result.a); + var model = result.a; + var stepper = stepperBuilder(sendToApp, model); + var ports = _Platform_setupEffects(managers, sendToApp); + + function sendToApp(msg, viewMetadata) + { + result = A2(update, msg, model); + stepper(model = result.a, viewMetadata); + _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + } + + _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + + return ports ? { ports: ports } : {}; +} + + + +// TRACK PRELOADS +// +// This is used by code in elm/browser and elm/http +// to register any HTTP requests that are triggered by init. +// + + +var _Platform_preload; + + +function _Platform_registerPreload(url) +{ + _Platform_preload.add(url); +} + + + +// EFFECT MANAGERS + + +var _Platform_effectManagers = {}; + + +function _Platform_setupEffects(managers, sendToApp) +{ + var ports; + + // setup all necessary effect managers + for (var key in _Platform_effectManagers) + { + var manager = _Platform_effectManagers[key]; + + if (manager.a) + { + ports = ports || {}; + ports[key] = manager.a(key, sendToApp); + } + + managers[key] = _Platform_instantiateManager(manager, sendToApp); + } + + return ports; +} + + +function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) +{ + return { + b: init, + c: onEffects, + d: onSelfMsg, + e: cmdMap, + f: subMap + }; +} + + +function _Platform_instantiateManager(info, sendToApp) +{ + var router = { + g: sendToApp, + h: undefined + }; + + var onEffects = info.c; + var onSelfMsg = info.d; + var cmdMap = info.e; + var subMap = info.f; + + function loop(state) + { + return A2(_Scheduler_andThen, loop, _Scheduler_receive(function(msg) + { + var value = msg.a; + + if (msg.$ === 0) + { + return A3(onSelfMsg, router, value, state); + } + + return cmdMap && subMap + ? A4(onEffects, router, value.i, value.j, state) + : A3(onEffects, router, cmdMap ? value.i : value.j, state); + })); + } + + return router.h = _Scheduler_rawSpawn(A2(_Scheduler_andThen, loop, info.b)); +} + + + +// ROUTING + + +var _Platform_sendToApp = F2(function(router, msg) +{ + return _Scheduler_binding(function(callback) + { + router.g(msg); + callback(_Scheduler_succeed(_Utils_Tuple0)); + }); +}); + + +var _Platform_sendToSelf = F2(function(router, msg) +{ + return A2(_Scheduler_send, router.h, { + $: 0, + a: msg + }); +}); + + + +// BAGS + + +function _Platform_leaf(home) +{ + return function(value) + { + return { + $: 1, + k: home, + l: value + }; + }; +} + + +function _Platform_batch(list) +{ + return { + $: 2, + m: list + }; +} + + +var _Platform_map = F2(function(tagger, bag) +{ + return { + $: 3, + n: tagger, + o: bag + } +}); + + + +// PIPE BAGS INTO EFFECT MANAGERS + + +function _Platform_dispatchEffects(managers, cmdBag, subBag) +{ + var effectsDict = {}; + _Platform_gatherEffects(true, cmdBag, effectsDict, null); + _Platform_gatherEffects(false, subBag, effectsDict, null); + + for (var home in managers) + { + _Scheduler_rawSend(managers[home], { + $: 'fx', + a: effectsDict[home] || { i: _List_Nil, j: _List_Nil } + }); + } +} + + +function _Platform_gatherEffects(isCmd, bag, effectsDict, taggers) +{ + switch (bag.$) + { + case 1: + var home = bag.k; + var effect = _Platform_toEffect(isCmd, home, taggers, bag.l); + effectsDict[home] = _Platform_insert(isCmd, effect, effectsDict[home]); + return; + + case 2: + for (var list = bag.m; list.b; list = list.b) // WHILE_CONS + { + _Platform_gatherEffects(isCmd, list.a, effectsDict, taggers); + } + return; + + case 3: + _Platform_gatherEffects(isCmd, bag.o, effectsDict, { + p: bag.n, + q: taggers + }); + return; + } +} + + +function _Platform_toEffect(isCmd, home, taggers, value) +{ + function applyTaggers(x) + { + for (var temp = taggers; temp; temp = temp.q) + { + x = temp.p(x); + } + return x; + } + + var map = isCmd + ? _Platform_effectManagers[home].e + : _Platform_effectManagers[home].f; + + return A2(map, applyTaggers, value) +} + + +function _Platform_insert(isCmd, newEffect, effects) +{ + effects = effects || { i: _List_Nil, j: _List_Nil }; + + isCmd + ? (effects.i = _List_Cons(newEffect, effects.i)) + : (effects.j = _List_Cons(newEffect, effects.j)); + + return effects; +} + + + +// PORTS + + +function _Platform_checkPortName(name) +{ + if (_Platform_effectManagers[name]) + { + _Debug_crash(3, name) + } +} + + + +// OUTGOING PORTS + + +function _Platform_outgoingPort(name, converter) +{ + _Platform_checkPortName(name); + _Platform_effectManagers[name] = { + e: _Platform_outgoingPortMap, + r: converter, + a: _Platform_setupOutgoingPort + }; + return _Platform_leaf(name); +} + + +var _Platform_outgoingPortMap = F2(function(tagger, value) { return value; }); + + +function _Platform_setupOutgoingPort(name) +{ + var subs = []; + var converter = _Platform_effectManagers[name].r; + + // CREATE MANAGER + + var init = _Process_sleep(0); + + _Platform_effectManagers[name].b = init; + _Platform_effectManagers[name].c = F3(function(router, cmdList, state) + { + for ( ; cmdList.b; cmdList = cmdList.b) // WHILE_CONS + { + // grab a separate reference to subs in case unsubscribe is called + var currentSubs = subs; + var value = _Json_unwrap(converter(cmdList.a)); + for (var i = 0; i < currentSubs.length; i++) + { + currentSubs[i](value); + } + } + return init; + }); + + // PUBLIC API + + function subscribe(callback) + { + subs.push(callback); + } + + function unsubscribe(callback) + { + // copy subs into a new array in case unsubscribe is called within a + // subscribed callback + subs = subs.slice(); + var index = subs.indexOf(callback); + if (index >= 0) + { + subs.splice(index, 1); + } + } + + return { + subscribe: subscribe, + unsubscribe: unsubscribe + }; +} + + + +// INCOMING PORTS + + +function _Platform_incomingPort(name, converter) +{ + _Platform_checkPortName(name); + _Platform_effectManagers[name] = { + f: _Platform_incomingPortMap, + r: converter, + a: _Platform_setupIncomingPort + }; + return _Platform_leaf(name); +} + + +var _Platform_incomingPortMap = F2(function(tagger, finalTagger) +{ + return function(value) + { + return tagger(finalTagger(value)); + }; +}); + + +function _Platform_setupIncomingPort(name, sendToApp) +{ + var subs = _List_Nil; + var converter = _Platform_effectManagers[name].r; + + // CREATE MANAGER + + var init = _Scheduler_succeed(null); + + _Platform_effectManagers[name].b = init; + _Platform_effectManagers[name].c = F3(function(router, subList, state) + { + subs = subList; + return init; + }); + + // PUBLIC API + + function send(incomingValue) + { + var result = A2(_Json_run, converter, _Json_wrap(incomingValue)); + + $elm$core$Result$isOk(result) || _Debug_crash(4, name, result.a); + + var value = result.a; + for (var temp = subs; temp.b; temp = temp.b) // WHILE_CONS + { + sendToApp(temp.a(value)); + } + } + + return { send: send }; +} + + + +// EXPORT ELM MODULES +// +// Have DEBUG and PROD versions so that we can (1) give nicer errors in +// debug mode and (2) not pay for the bits needed for that in prod mode. +// + + +function _Platform_export_UNUSED(exports) +{ + scope['Elm'] + ? _Platform_mergeExportsProd(scope['Elm'], exports) + : scope['Elm'] = exports; +} + + +function _Platform_mergeExportsProd(obj, exports) +{ + for (var name in exports) + { + (name in obj) + ? (name == 'init') + ? _Debug_crash(6) + : _Platform_mergeExportsProd(obj[name], exports[name]) + : (obj[name] = exports[name]); + } +} + + +function _Platform_export(exports) +{ + scope['Elm'] + ? _Platform_mergeExportsDebug('Elm', scope['Elm'], exports) + : scope['Elm'] = exports; +} + + +function _Platform_mergeExportsDebug(moduleName, obj, exports) +{ + for (var name in exports) + { + (name in obj) + ? (name == 'init') + ? _Debug_crash(6, moduleName) + : _Platform_mergeExportsDebug(moduleName + '.' + name, obj[name], exports[name]) + : (obj[name] = exports[name]); + } +} +var $elm$core$Basics$EQ = {$: 'EQ'}; +var $elm$core$Basics$LT = {$: 'LT'}; +var $elm$core$List$cons = _List_cons; +var $elm$core$Elm$JsArray$foldr = _JsArray_foldr; +var $elm$core$Array$foldr = F3( + function (func, baseCase, _v0) { + var tree = _v0.c; + var tail = _v0.d; + var helper = F2( + function (node, acc) { + if (node.$ === 'SubTree') { + var subTree = node.a; + return A3($elm$core$Elm$JsArray$foldr, helper, acc, subTree); + } else { + var values = node.a; + return A3($elm$core$Elm$JsArray$foldr, func, acc, values); + } + }); + return A3( + $elm$core$Elm$JsArray$foldr, + helper, + A3($elm$core$Elm$JsArray$foldr, func, baseCase, tail), + tree); + }); +var $elm$core$Array$toList = function (array) { + return A3($elm$core$Array$foldr, $elm$core$List$cons, _List_Nil, array); +}; +var $elm$core$Dict$foldr = F3( + function (func, acc, t) { + foldr: + while (true) { + if (t.$ === 'RBEmpty_elm_builtin') { + return acc; + } else { + var key = t.b; + var value = t.c; + var left = t.d; + var right = t.e; + var $temp$func = func, + $temp$acc = A3( + func, + key, + value, + A3($elm$core$Dict$foldr, func, acc, right)), + $temp$t = left; + func = $temp$func; + acc = $temp$acc; + t = $temp$t; + continue foldr; + } + } + }); +var $elm$core$Dict$toList = function (dict) { + return A3( + $elm$core$Dict$foldr, + F3( + function (key, value, list) { + return A2( + $elm$core$List$cons, + _Utils_Tuple2(key, value), + list); + }), + _List_Nil, + dict); +}; +var $elm$core$Dict$keys = function (dict) { + return A3( + $elm$core$Dict$foldr, + F3( + function (key, value, keyList) { + return A2($elm$core$List$cons, key, keyList); + }), + _List_Nil, + dict); +}; +var $elm$core$Set$toList = function (_v0) { + var dict = _v0.a; + return $elm$core$Dict$keys(dict); +}; +var $elm$core$Basics$GT = {$: 'GT'}; +var $elm$core$Basics$True = {$: 'True'}; +var $elm$core$Basics$composeR = F3( + function (f, g, x) { + return g( + f(x)); + }); +var $elm$core$Basics$add = _Basics_add; +var $elm$core$Basics$fdiv = _Basics_fdiv; +var $author$project$OperatorExample$mean = F2( + function (a, b) { + return (a + b) / 2; + }); +var $author$project$OperatorExample$compositionExample = function (x) { + return A2( + $elm$core$Basics$composeR, + $author$project$OperatorExample$mean(6), + $author$project$OperatorExample$mean(x)); +}; +var $elm$core$Basics$not = _Basics_not; +var $author$project$OperatorExample$ident = function (b) { + return !(!b); +}; +var $elm$core$Result$Err = function (a) { + return {$: 'Err', a: a}; +}; +var $elm$json$Json$Decode$Failure = F2( + function (a, b) { + return {$: 'Failure', a: a, b: b}; + }); +var $elm$json$Json$Decode$Field = F2( + function (a, b) { + return {$: 'Field', a: a, b: b}; + }); +var $elm$json$Json$Decode$Index = F2( + function (a, b) { + return {$: 'Index', a: a, b: b}; + }); +var $elm$core$Result$Ok = function (a) { + return {$: 'Ok', a: a}; +}; +var $elm$json$Json$Decode$OneOf = function (a) { + return {$: 'OneOf', a: a}; +}; +var $elm$core$Basics$False = {$: 'False'}; +var $elm$core$Maybe$Just = function (a) { + return {$: 'Just', a: a}; +}; +var $elm$core$Maybe$Nothing = {$: 'Nothing'}; +var $elm$core$String$all = _String_all; +var $elm$core$Basics$and = _Basics_and; +var $elm$core$Basics$append = _Utils_append; +var $elm$json$Json$Encode$encode = _Json_encode; +var $elm$core$String$fromInt = _String_fromNumber; +var $elm$core$String$join = F2( + function (sep, chunks) { + return A2( + _String_join, + sep, + _List_toArray(chunks)); + }); +var $elm$core$String$split = F2( + function (sep, string) { + return _List_fromArray( + A2(_String_split, sep, string)); + }); +var $elm$json$Json$Decode$indent = function (str) { + return A2( + $elm$core$String$join, + '\n ', + A2($elm$core$String$split, '\n', str)); +}; +var $elm$core$List$foldl = F3( + function (func, acc, list) { + foldl: + while (true) { + if (!list.b) { + return acc; + } else { + var x = list.a; + var xs = list.b; + var $temp$func = func, + $temp$acc = A2(func, x, acc), + $temp$list = xs; + func = $temp$func; + acc = $temp$acc; + list = $temp$list; + continue foldl; + } + } + }); +var $elm$core$List$length = function (xs) { + return A3( + $elm$core$List$foldl, + F2( + function (_v0, i) { + return i + 1; + }), + 0, + xs); +}; +var $elm$core$List$map2 = _List_map2; +var $elm$core$Basics$le = _Utils_le; +var $elm$core$Basics$sub = _Basics_sub; +var $elm$core$List$rangeHelp = F3( + function (lo, hi, list) { + rangeHelp: + while (true) { + if (_Utils_cmp(lo, hi) < 1) { + var $temp$lo = lo, + $temp$hi = hi - 1, + $temp$list = A2($elm$core$List$cons, hi, list); + lo = $temp$lo; + hi = $temp$hi; + list = $temp$list; + continue rangeHelp; + } else { + return list; + } + } + }); +var $elm$core$List$range = F2( + function (lo, hi) { + return A3($elm$core$List$rangeHelp, lo, hi, _List_Nil); + }); +var $elm$core$List$indexedMap = F2( + function (f, xs) { + return A3( + $elm$core$List$map2, + f, + A2( + $elm$core$List$range, + 0, + $elm$core$List$length(xs) - 1), + xs); + }); +var $elm$core$Char$toCode = _Char_toCode; +var $elm$core$Char$isLower = function (_char) { + var code = $elm$core$Char$toCode(_char); + return (97 <= code) && (code <= 122); +}; +var $elm$core$Char$isUpper = function (_char) { + var code = $elm$core$Char$toCode(_char); + return (code <= 90) && (65 <= code); +}; +var $elm$core$Basics$or = _Basics_or; +var $elm$core$Char$isAlpha = function (_char) { + return $elm$core$Char$isLower(_char) || $elm$core$Char$isUpper(_char); +}; +var $elm$core$Char$isDigit = function (_char) { + var code = $elm$core$Char$toCode(_char); + return (code <= 57) && (48 <= code); +}; +var $elm$core$Char$isAlphaNum = function (_char) { + return $elm$core$Char$isLower(_char) || ($elm$core$Char$isUpper(_char) || $elm$core$Char$isDigit(_char)); +}; +var $elm$core$List$reverse = function (list) { + return A3($elm$core$List$foldl, $elm$core$List$cons, _List_Nil, list); +}; +var $elm$core$String$uncons = _String_uncons; +var $elm$json$Json$Decode$errorOneOf = F2( + function (i, error) { + return '\n\n(' + ($elm$core$String$fromInt(i + 1) + (') ' + $elm$json$Json$Decode$indent( + $elm$json$Json$Decode$errorToString(error)))); + }); +var $elm$json$Json$Decode$errorToString = function (error) { + return A2($elm$json$Json$Decode$errorToStringHelp, error, _List_Nil); +}; +var $elm$json$Json$Decode$errorToStringHelp = F2( + function (error, context) { + errorToStringHelp: + while (true) { + switch (error.$) { + case 'Field': + var f = error.a; + var err = error.b; + var isSimple = function () { + var _v1 = $elm$core$String$uncons(f); + if (_v1.$ === 'Nothing') { + return false; + } else { + var _v2 = _v1.a; + var _char = _v2.a; + var rest = _v2.b; + return $elm$core$Char$isAlpha(_char) && A2($elm$core$String$all, $elm$core$Char$isAlphaNum, rest); + } + }(); + var fieldName = isSimple ? ('.' + f) : ('[\'' + (f + '\']')); + var $temp$error = err, + $temp$context = A2($elm$core$List$cons, fieldName, context); + error = $temp$error; + context = $temp$context; + continue errorToStringHelp; + case 'Index': + var i = error.a; + var err = error.b; + var indexName = '[' + ($elm$core$String$fromInt(i) + ']'); + var $temp$error = err, + $temp$context = A2($elm$core$List$cons, indexName, context); + error = $temp$error; + context = $temp$context; + continue errorToStringHelp; + case 'OneOf': + var errors = error.a; + if (!errors.b) { + return 'Ran into a Json.Decode.oneOf with no possibilities' + function () { + if (!context.b) { + return '!'; + } else { + return ' at json' + A2( + $elm$core$String$join, + '', + $elm$core$List$reverse(context)); + } + }(); + } else { + if (!errors.b.b) { + var err = errors.a; + var $temp$error = err, + $temp$context = context; + error = $temp$error; + context = $temp$context; + continue errorToStringHelp; + } else { + var starter = function () { + if (!context.b) { + return 'Json.Decode.oneOf'; + } else { + return 'The Json.Decode.oneOf at json' + A2( + $elm$core$String$join, + '', + $elm$core$List$reverse(context)); + } + }(); + var introduction = starter + (' failed in the following ' + ($elm$core$String$fromInt( + $elm$core$List$length(errors)) + ' ways:')); + return A2( + $elm$core$String$join, + '\n\n', + A2( + $elm$core$List$cons, + introduction, + A2($elm$core$List$indexedMap, $elm$json$Json$Decode$errorOneOf, errors))); + } + } + default: + var msg = error.a; + var json = error.b; + var introduction = function () { + if (!context.b) { + return 'Problem with the given value:\n\n'; + } else { + return 'Problem with the value at json' + (A2( + $elm$core$String$join, + '', + $elm$core$List$reverse(context)) + ':\n\n '); + } + }(); + return introduction + ($elm$json$Json$Decode$indent( + A2($elm$json$Json$Encode$encode, 4, json)) + ('\n\n' + msg)); + } + } + }); +var $elm$core$Array$branchFactor = 32; +var $elm$core$Array$Array_elm_builtin = F4( + function (a, b, c, d) { + return {$: 'Array_elm_builtin', a: a, b: b, c: c, d: d}; + }); +var $elm$core$Elm$JsArray$empty = _JsArray_empty; +var $elm$core$Basics$ceiling = _Basics_ceiling; +var $elm$core$Basics$logBase = F2( + function (base, number) { + return _Basics_log(number) / _Basics_log(base); + }); +var $elm$core$Basics$toFloat = _Basics_toFloat; +var $elm$core$Array$shiftStep = $elm$core$Basics$ceiling( + A2($elm$core$Basics$logBase, 2, $elm$core$Array$branchFactor)); +var $elm$core$Array$empty = A4($elm$core$Array$Array_elm_builtin, 0, $elm$core$Array$shiftStep, $elm$core$Elm$JsArray$empty, $elm$core$Elm$JsArray$empty); +var $elm$core$Elm$JsArray$initialize = _JsArray_initialize; +var $elm$core$Array$Leaf = function (a) { + return {$: 'Leaf', a: a}; +}; +var $elm$core$Basics$apL = F2( + function (f, x) { + return f(x); + }); +var $elm$core$Basics$apR = F2( + function (x, f) { + return f(x); + }); +var $elm$core$Basics$eq = _Utils_equal; +var $elm$core$Basics$floor = _Basics_floor; +var $elm$core$Elm$JsArray$length = _JsArray_length; +var $elm$core$Basics$gt = _Utils_gt; +var $elm$core$Basics$max = F2( + function (x, y) { + return (_Utils_cmp(x, y) > 0) ? x : y; + }); +var $elm$core$Basics$mul = _Basics_mul; +var $elm$core$Array$SubTree = function (a) { + return {$: 'SubTree', a: a}; +}; +var $elm$core$Elm$JsArray$initializeFromList = _JsArray_initializeFromList; +var $elm$core$Array$compressNodes = F2( + function (nodes, acc) { + compressNodes: + while (true) { + var _v0 = A2($elm$core$Elm$JsArray$initializeFromList, $elm$core$Array$branchFactor, nodes); + var node = _v0.a; + var remainingNodes = _v0.b; + var newAcc = A2( + $elm$core$List$cons, + $elm$core$Array$SubTree(node), + acc); + if (!remainingNodes.b) { + return $elm$core$List$reverse(newAcc); + } else { + var $temp$nodes = remainingNodes, + $temp$acc = newAcc; + nodes = $temp$nodes; + acc = $temp$acc; + continue compressNodes; + } + } + }); +var $elm$core$Tuple$first = function (_v0) { + var x = _v0.a; + return x; +}; +var $elm$core$Array$treeFromBuilder = F2( + function (nodeList, nodeListSize) { + treeFromBuilder: + while (true) { + var newNodeSize = $elm$core$Basics$ceiling(nodeListSize / $elm$core$Array$branchFactor); + if (newNodeSize === 1) { + return A2($elm$core$Elm$JsArray$initializeFromList, $elm$core$Array$branchFactor, nodeList).a; + } else { + var $temp$nodeList = A2($elm$core$Array$compressNodes, nodeList, _List_Nil), + $temp$nodeListSize = newNodeSize; + nodeList = $temp$nodeList; + nodeListSize = $temp$nodeListSize; + continue treeFromBuilder; + } + } + }); +var $elm$core$Array$builderToArray = F2( + function (reverseNodeList, builder) { + if (!builder.nodeListSize) { + return A4( + $elm$core$Array$Array_elm_builtin, + $elm$core$Elm$JsArray$length(builder.tail), + $elm$core$Array$shiftStep, + $elm$core$Elm$JsArray$empty, + builder.tail); + } else { + var treeLen = builder.nodeListSize * $elm$core$Array$branchFactor; + var depth = $elm$core$Basics$floor( + A2($elm$core$Basics$logBase, $elm$core$Array$branchFactor, treeLen - 1)); + var correctNodeList = reverseNodeList ? $elm$core$List$reverse(builder.nodeList) : builder.nodeList; + var tree = A2($elm$core$Array$treeFromBuilder, correctNodeList, builder.nodeListSize); + return A4( + $elm$core$Array$Array_elm_builtin, + $elm$core$Elm$JsArray$length(builder.tail) + treeLen, + A2($elm$core$Basics$max, 5, depth * $elm$core$Array$shiftStep), + tree, + builder.tail); + } + }); +var $elm$core$Basics$idiv = _Basics_idiv; +var $elm$core$Basics$lt = _Utils_lt; +var $elm$core$Array$initializeHelp = F5( + function (fn, fromIndex, len, nodeList, tail) { + initializeHelp: + while (true) { + if (fromIndex < 0) { + return A2( + $elm$core$Array$builderToArray, + false, + {nodeList: nodeList, nodeListSize: (len / $elm$core$Array$branchFactor) | 0, tail: tail}); + } else { + var leaf = $elm$core$Array$Leaf( + A3($elm$core$Elm$JsArray$initialize, $elm$core$Array$branchFactor, fromIndex, fn)); + var $temp$fn = fn, + $temp$fromIndex = fromIndex - $elm$core$Array$branchFactor, + $temp$len = len, + $temp$nodeList = A2($elm$core$List$cons, leaf, nodeList), + $temp$tail = tail; + fn = $temp$fn; + fromIndex = $temp$fromIndex; + len = $temp$len; + nodeList = $temp$nodeList; + tail = $temp$tail; + continue initializeHelp; + } + } + }); +var $elm$core$Basics$remainderBy = _Basics_remainderBy; +var $elm$core$Array$initialize = F2( + function (len, fn) { + if (len <= 0) { + return $elm$core$Array$empty; + } else { + var tailLen = len % $elm$core$Array$branchFactor; + var tail = A3($elm$core$Elm$JsArray$initialize, tailLen, len - tailLen, fn); + var initialFromIndex = (len - tailLen) - $elm$core$Array$branchFactor; + return A5($elm$core$Array$initializeHelp, fn, initialFromIndex, len, _List_Nil, tail); + } + }); +var $elm$core$Result$isOk = function (result) { + if (result.$ === 'Ok') { + return true; + } else { + return false; + } +}; +var $elm$core$Platform$Cmd$batch = _Platform_batch; +var $elm$core$Platform$Cmd$none = $elm$core$Platform$Cmd$batch(_List_Nil); +var $elm$core$Platform$Sub$batch = _Platform_batch; +var $elm$core$Platform$Sub$none = $elm$core$Platform$Sub$batch(_List_Nil); +var $elm$json$Json$Decode$succeed = _Json_succeed; +var $elm$core$Platform$worker = _Platform_worker; +var $author$project$OperatorExample$main = function () { + var m = A2($author$project$OperatorExample$compositionExample, 21, 4); + var _v0 = $author$project$OperatorExample$ident(true); + return $elm$core$Platform$worker( + { + init: function (_v1) { + return _Utils_Tuple2(m, $elm$core$Platform$Cmd$none); + }, + subscriptions: function (_v2) { + return $elm$core$Platform$Sub$none; + }, + update: F2( + function (model, _v3) { + return _Utils_Tuple2(model, $elm$core$Platform$Cmd$none); + }) + }); +}(); +_Platform_export({'OperatorExample':{'init':$author$project$OperatorExample$main( + $elm$json$Json$Decode$succeed(_Utils_Tuple0))(0)}});}(this)); diff --git a/design-documents/elm-minimal-master/src/Main.elm b/design-documents/elm-minimal-master/src/Main.elm new file mode 100644 index 00000000..71cb1228 --- /dev/null +++ b/design-documents/elm-minimal-master/src/Main.elm @@ -0,0 +1,31 @@ +module Main exposing (..) + +import Platform + + +arithmeticMean : Float -> Float -> Float +arithmeticMean a b = + (a + b) / 2 + + +geometricMean : Float -> Float -> Float +geometricMean a b = + sqrt (a * b) + + +compositionExample : (Float -> Float) +compositionExample = + arithmeticMean 6 + >> geometricMean 20 + + +main = + let + m = compositionExample 4 + in + + Platform.worker + { init = \() -> (m, Cmd.none) + , update = \model _ -> (model, Cmd.none) + , subscriptions = \_ -> Sub.none + } diff --git a/design-documents/elm-minimal-master/src/OperatorExample.elm b/design-documents/elm-minimal-master/src/OperatorExample.elm new file mode 120000 index 00000000..2e2dbf7f --- /dev/null +++ b/design-documents/elm-minimal-master/src/OperatorExample.elm @@ -0,0 +1 @@ +../../OperatorExample.elm \ No newline at end of file diff --git a/design-documents/operators.md b/design-documents/operators.md new file mode 100644 index 00000000..c29d900c --- /dev/null +++ b/design-documents/operators.md @@ -0,0 +1,337 @@ +# Operators in elm + +Elm programs use operators to consisely write some of the most common code. +For instance, elm provides arithmetic operators; it is far more consise to write `x * 5 + 1` than its equivilent written using functions (e.g. `add (multiply x 5) 1`). + +Starting with the 0.19 release series only "core"¹ modules can define operators, effectively fixing the number of operators in the language. +The operators used by elm are [listed below](#listing). + +## Defining operators + +In elm, operators are defined in terms of a function. +For example in `elm/core` the `Basics` module defines the addition operator `+` + +```elm + +infix left 6 (+) = add +-- ^ ^ ^ ^ ^ +-- | | | | | +-- (1) | (3)| (5) +-- (2) (4) + +add : number -> number -> number +add = + Elm.Kernel.Basics.add + +``` + +where `Elm.Kernel.Basics.add` is defined in JavaScript + +```js +var _Basics_add = F2(function(a, b) { return a + b; }); +``` + +The operator definition contains + +1. The `infix` keyword enables the compiler to parse this line as an operator definition. +2. Associativity, in this case `left` meaning the compiler parses `4 + 5 + 7` as `(4 + 5) + 7`. +3. The precedence controlls what happens when different operators are used together. + For example, `(+)` has precedence 6 and `(*)` has precedence 7 so the compiler parses `4 + 5 * 7` as `4 + (5 * 7)`. +4. The operator name enclosed in parentheses. +5. The function that the operator will bind to. + Operators provide a simpler syntax for calling a function; the elm code `a + b` is equivilent to the code `Basics.add a b` (except the function `add` is not exposed by the `Basics` module). + +## Compiling operators + +All examples in this section are found within [OperatorExample.elm](./OperatorExample.elm) using `elm/core` version `1.0.2` and the offical elm compiler version `0.19.1`. + +These are the elm functions we will use + +```elm +compositionExample : (Float -> Float -> Float) +compositionExample x = + mean 6 + >> mean x + +mean : Float -> Float -> Float +mean a b = + (a + b) / 2 + + +ident : Bool -> Bool +ident b = + not (not b) +``` + +### Operators: shorthand for functions + +The operator `>>` composes functions together, for example `mean 6 >> mean x` is equilent to `\dummy => mean x (mean 6 dummy)`. +Compiling `compositionExample` generates the folling JavaScript: + +```js +var $author$project$OperatorExample$compositionExample = function (x) { + return A2( + $elm$core$Basics$composeR, + $author$project$OperatorExample$mean(6), + $author$project$OperatorExample$mean(x)); +}; + +``` + +It is clear that the compiler treats `mean 6 >> mean 21` as the function call `Basics.composeR (mean 6) mean(21)`; the operator has been substituted for a call to the function from which the operator is defined. + +### Operaters: a suprising result + +However, when we look at the JavaScript generated for `mean` we see something quite different: + +```js +var $author$project$OperatorExample$mean = F2( + function (a, b) { + return (a + b) / 2; + }); + +``` + +The compiler does not generate a call to `Basics.add` for the operator `+`, nor has does it generate a call to `Basics.fdiv` for the operator `/`! +Does this mean that using operators is not equivalent to calling the function from which it is defined? +No, it does not. +To see why take a look at the generated javascript for a third example `ident`. +`ident` takes a boolean value and inverts it twice so that it will always return the value it is given. + +```js +var $author$project$OperatorExample$ident = function (b) { + return !(!b); +}; +``` + +As with `mean`, the compiler has refused to generate a call to `Basics.not` and instead uses the javascript `!` operator. +To understand this we need to dip our toes into the source code of the compiler itself. + +### Special cases + +In the section titled [Defining operators](#defining-operators) I claimed that "the elm code `a + b` is equivilent to the code `Basics.add a b`". +How can this be true if the compiler generated JavaScript for our example `mean` function does not contain a call to `$elm$core$Basics.add$`? +Surely the elm compiler must special case the addition operator? + +No! +The elm compiler does not special case the addition operator; it special-cases `Basics.add`! +It also special-cases `Basics.not` expaining the generated JavaScript for our function `ident`. +Let us look at the Haskell code that makes these cases special: + +#### [`generateCall`](https://github.com/elm/compiler/blob/0.19.1/compiler/src/Generate/JavaScript/Expression.hs#L386) + +This haskell function generates JavaScript for every elm function call, we can see that it usually uses `generateCallHelp` to generate JavaScript. +However, when calling a function in the `elm/core` package the function instead calls `generateCoreCall`. + +```hs +generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCall mode func args = + case func of + Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core -> + generateCoreCall mode global args + + -- snip + + _ -> + generateCallHelp mode func args +``` + +#### [`generateCoreCall`](https://github.com/elm/compiler/blob/0.19.1/compiler/src/Generate/JavaScript/Expression.hs#L442) + +`generateCoreCall` detects calls to function in the `Basics` module (and a couple of other modules not shown here) and calls `generateBasicsCall`. +Like `generateCall`, uses `generateCallHelp` to handle any calls to functions defined in modules the compile does not have a special case for. + +```hs +generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr +generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = + if moduleName == Name.basics then + generateBasicsCall mode home name args + + -- snip + + else + generateGlobalCall home name (map (generateJsExpr mode) args) +``` + +#### [src/Generate/JavaScript/Expression.hs](https://github.com/elm/compiler/blob/0.19.1/compiler/src/Generate/JavaScript/Expression.hs#L503) + +```hs +generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr +generateBasicsCall mode home name args = + case args of + [elmArg] -> + let arg = generateJsExpr mode elmArg in + case name of + "not" -> JS.Prefix JS.PrefixNot arg + -- snip + _ -> generateGlobalCall home name [arg] + + [elmLeft, elmRight] -> + case name of + -- snip + _ -> + let + left = generateJsExpr mode elmLeft + right = generateJsExpr mode elmRight + in + case name of + "add" -> JS.Infix JS.OpAdd left right + + -- snip + + _ -> generateGlobalCall home name [left, right] + + _ -> + generateGlobalCall home name (map (generateJsExpr mode) args) +``` + +## Elm operator listing + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
PrecedenceSyntaxDescriptionSourceAssociativity
9 +

highest

+ 		f << gFunctional compositionelm/core:Basicsconflicting
g >> fFunctional compositionelm/core:Basicsconflicting
8a ^ bExponentationelm/core:Basicsright-to-left
7a * bMultiplicationelm/core:Basicsleft-to-right
a / bFloating-point divisionelm/core:Basics
a // bInteger divisionelm/core:Basics
6a + bAdditionelm/core:Basicsleft-to-right
a - bSubtractionelm/core:Basics
5xs ++ ysAppendelm/core:Basicsright-to-left
a :: xsList constructionelm/core:List
4a == bEqualityelm/core:Basicsconflicting
a /= bInequalityelm/core:Basics
a < bLess thanelm/core:Basics
a > bGreater thanelm/core:Basics
a <= bLess than equal toelm/core:Basics
a >= bGreater than equal toelm/core:Basics
3a && bLogical ANDelm/core:Basicsright-to-left
2a || bLogical ORelm/core:Basicsright-to-left
0 +

lowest

+ 		a |> bPipe operatorelm/core:Basicsconflicts
a <| bPipe operatorelm/core:Basics
+ +--- + +### Notes + +1. "Core" modules describe all modules in the elm and elm-exploration organisations. diff --git a/design-documents/table.html b/design-documents/table.html new file mode 100644 index 00000000..36ab6cec --- /dev/null +++ b/design-documents/table.html @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
PrecedenceSyntaxDescriptionAssociativity
9 +

highest

+ 		f << gFunctional compositionconflicting
g >> fFunctional compositionright-to-left
8a ^ bExponentationright-to-left (?)
7a * bMultiplicationleft-to-right
a / bFloating-point division
a // bInteger-point division
diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 26fd57e5..5cdee5dd 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -162,7 +162,7 @@ var _Platform_sendToApp = F2(function(router, msg) { router.__sendToApp(msg); callback(__Scheduler_succeed(__Utils_Tuple0)); - }); + }, false); }); diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 37a68be8..8badd750 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -9,187 +9,178 @@ import Elm.Kernel.Utils exposing (Tuple0) function _Scheduler_succeed(value) { + /**__DEBUG/ return { - $: __1_SUCCEED, - __value: value + $: 'Succeed', + a: value }; + //*/ + + /**__PROD/ + return { + $: 0, + a: value + }; + //*/ } function _Scheduler_fail(error) { + /**__DEBUG/ + return { + $: 'Fail', + a: error + }; + //*/ + + /**__PROD/ return { - $: __1_FAIL, - __value: error + $: 1, + a: error }; + //*/ } -function _Scheduler_binding(callback) +function _Scheduler_binding(callback, killable) { + /**__DEBUG/ return { - $: __1_BINDING, - __callback: callback, - __kill: null + $: 'Binding', + a: killable + ? function(x) { + return { + $: 'Just', + a: callback(x), + }; + } + : function(x) { + callback(x); + return { + $: 'Nothing', + } + } + b: {$: 'Nothing'} }; + //*/ + + /**__PROD/ + return { + $: 2, + a: killable + ? function(x) { + return { + $: 0, + a: callback(x), + }; + } + : function(x) { + callback(x); + return { + $: 1, + } + } + b: {$: 1} + }; + //*/ } var _Scheduler_andThen = F2(function(callback, task) { + /**__DEBUG/ return { - $: __1_AND_THEN, - __callback: callback, - __task: task + $: 'AndThen', + a: callback + b: task }; + //*/ + + /**__PROD/ + return { + $: 3, + a: callback + b: task + }; + //*/ }); var _Scheduler_onError = F2(function(callback, task) { + /**__DEBUG/ + return { + $: 'OnError', + a: callback + b: task + }; + //*/ + + /**__PROD/ return { - $: __1_ON_ERROR, - __callback: callback, - __task: task + $: 4, + a: callback + b: task }; + //*/ }); function _Scheduler_receive(callback) { + /**__DEBUG/ + return { + $: 'Receive', + a: callback + }; + //*/ + + /**__PROD/ return { - $: __1_RECEIVE, - __callback: callback + $: 5, + a: callback }; + //*/ } // PROCESSES var _Scheduler_guid = 0; +var _Scheduler_processes = new WeakMap(); -function _Scheduler_rawSpawn(task) -{ - var proc = { - $: __2_PROCESS, - __id: _Scheduler_guid++, - __root: task, - __stack: null, - __mailbox: [] - }; - - _Scheduler_enqueue(proc); - - return proc; +function _Sceduler_getGuid() { + return Object.create({ id: _Scheduler_guid++ }); } -function _Scheduler_spawn(task) -{ - return _Scheduler_binding(function(callback) { - callback(_Scheduler_succeed(_Scheduler_rawSpawn(task))); - }); -} - -function _Scheduler_rawSend(proc, msg) -{ - proc.__mailbox.push(msg); - _Scheduler_enqueue(proc); +function _Sceduler_register(proc) { + _Scheduler_processes.set(proc.id, proc); + return proc; } -var _Scheduler_send = F2(function(proc, msg) -{ - return _Scheduler_binding(function(callback) { - _Scheduler_rawSend(proc, msg); - callback(_Scheduler_succeed(__Utils_Tuple0)); - }); -}); - -function _Scheduler_kill(proc) -{ - return _Scheduler_binding(function(callback) { - var task = proc.__root; - if (task.$ === __1_BINDING && task.__kill) - { - task.__kill(); - } - - proc.__root = null; - - callback(_Scheduler_succeed(__Utils_Tuple0)); - }); +function _Sceduler_getProcess(id) { + const proc = _Scheduler_processes.get(id); + /**__DEBUG/ + if (proc === undefined) { + console.error(`INTERNAL ERROR: Process with id ${id} is not in map!`); + } + //*/ + return proc; } - -/* STEP PROCESSES - -type alias Process = - { $ : tag - , id : unique_id - , root : Task - , stack : null | { $: SUCCEED | FAIL, a: callback, b: stack } - , mailbox : [msg] - } - -*/ - - var _Scheduler_working = false; var _Scheduler_queue = []; - -function _Scheduler_enqueue(proc) +var _Scheduler_enqueue = F2(function(stepper, procId) { - _Scheduler_queue.push(proc); + _Scheduler_queue.push(procId); if (_Scheduler_working) { return; } _Scheduler_working = true; - while (proc = _Scheduler_queue.shift()) + while (procId = _Scheduler_queue.shift()) { - _Scheduler_step(proc); + const process = _Scheduler_processes.get(procId); + newProcess = stepper(process); + _Scheduler_processes.set(procId, process); } _Scheduler_working = false; -} - +}); -function _Scheduler_step(proc) -{ - while (proc.__root) - { - var rootTag = proc.__root.$; - if (rootTag === __1_SUCCEED || rootTag === __1_FAIL) - { - while (proc.__stack && proc.__stack.$ !== rootTag) - { - proc.__stack = proc.__stack.__rest; - } - if (!proc.__stack) - { - return; - } - proc.__root = proc.__stack.__callback(proc.__root.__value); - proc.__stack = proc.__stack.__rest; - } - else if (rootTag === __1_BINDING) - { - proc.__root.__kill = proc.__root.__callback(function(newRoot) { - proc.__root = newRoot; - _Scheduler_enqueue(proc); - }); - return; - } - else if (rootTag === __1_RECEIVE) - { - if (proc.__mailbox.length === 0) - { - return; - } - proc.__root = proc.__root.__callback(proc.__mailbox.shift()); - } - else // if (rootTag === __1_AND_THEN || rootTag === __1_ON_ERROR) - { - proc.__stack = { - $: rootTag === __1_AND_THEN ? __1_SUCCEED : __1_FAIL, - __callback: proc.__root.__callback, - __rest: proc.__stack - }; - proc.__root = proc.__root.__task; - } - } -} diff --git a/src/Platform.elm b/src/Platform.elm index aced3829..a3c9ff40 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -27,9 +27,11 @@ curious? Public discussions of your explorations should be framed accordingly. import Basics exposing (Never) import Elm.Kernel.Platform -import Elm.Kernel.Scheduler +import Platform.Scheduler as Scheduler import Platform.Cmd exposing (Cmd) import Platform.Sub exposing (Sub) +import Platform.Bag as Bag +import Maybe exposing (Maybe(..)) @@ -80,14 +82,13 @@ worker = information on this. It is only defined here because it is a platform primitive. -} -type Task err ok = Task - +type alias Task err ok = Scheduler.Task err ok {-| Head over to the documentation for the [`Process`](Process) module for information on this. It is only defined here because it is a platform primitive. -} -type ProcessId = ProcessId +type alias ProcessId = Scheduler.Id @@ -99,14 +100,27 @@ the main app and your individual effect manager. -} type Router appMsg selfMsg = Router - + { sendToApp: appMsg -> () + , selfProcess: ProcessId + } {-| Send the router a message for the main loop of your app. This message will be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () -sendToApp = - Elm.Kernel.Platform.sendToApp +sendToApp (Router router) msg = + Scheduler.binding + (\doneCallback -> + let + _ = + router.sendToApp msg + in + let + _ = + doneCallback (Scheduler.Succeed ()) + in + Nothing + ) {-| Send the router a message for your effect manager. This message will @@ -116,5 +130,7 @@ effect manager as necessary. As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () -sendToSelf = - Elm.Kernel.Platform.sendToSelf +sendToSelf (Router router) msg = + Scheduler.send + router.selfProcess + (Bag.Self msg) diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index 1d588f3b..dd21bc96 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -1,5 +1,5 @@ module Platform.Bag exposing - ( Bag + ( Bag(..) , batch , map ) @@ -14,7 +14,7 @@ type Bag msg = Leaf -- let kernel code handle this one | Batch (List (Bag msg)) | Map (BagHiddenValue -> msg) (Bag BagHiddenValue) - | Self -- kernel code gets this one too + | Self msg batch : List (Bag msg) -> Bag msg diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm new file mode 100644 index 00000000..ac869d36 --- /dev/null +++ b/src/Platform/Scheduler.elm @@ -0,0 +1,332 @@ +module Platform.Scheduler exposing (..) + +{-| + +## Module notes: + +* Types called `HiddenXXX` are used to bypass the elm type system. + The programmer takes **full responsibiliy** for making sure + that the types line up. + That does mean you have to second guess any and all strange + decisions I have made, hopefully things will get clearer over + time. +- The `Binding` constructor on the `Task` type is tricky one. + + It contains a callback function (that we will call `doEffect`) + and a `killer` function. `doEffect` will be called by + `Scheduler.enqueue` and will be passed another callback. + We call this second callback `doneCallback`. + `doEffect` should do its effects (which may be impure) and then, + when it is done, call `doneCallback`.`doEffect` **must** call + `doneCallback` and it **must** pass `doneCallback` a + `Task ErrX OkX` as an argument. (I am unsure about the values of + ErrX and OkX at the moment). The return value of `doEffect` may + be either `undefined` or a function that cancels the effect. + + If the second value `killer` is not Nothing, then the runtime + will call it if the execution of the `Task` should be aborted. + + + + + + +## Differences between this and offical elm/core + +* `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. +* `Process.stack` is an (immutable) js linked list in elm/core and an elm list here. +* `Elm.Kernel.Scheduler.rawSend` mutates the process before enqueuing it in elm/core. + Here we create a **new** process with the **same** (unique) id and then enqueue it. + Same applies for (non-raw) `send`. + +-} + +import Basics exposing (Never, Int, (++), Bool(..)) +import Maybe exposing (Maybe(..)) +import Elm.Kernel.Basics +import Debug +import List exposing ((::)) + +type Task err ok + = Succeed ok + | Fail err + | Binding (BindingCallbackAlias err ok) (Maybe KillThunk) + -- todo binding callback type args + | AndThen (HiddenOk -> Task err ok) (Task err HiddenOk) + | OnError (HiddenErr -> Task err ok) (Task HiddenErr ok) + | Receive (HiddenMsg -> Task err ok) + + +type Process msg + = Process + { id : Id msg + , root : Task HiddenErr HiddenOk + , stack : List (StackItem HiddenErr HiddenOk) + , mailbox : List msg + } + + +binding : BindingCallbackAlias err ok -> Task err ok +binding callback = + Binding + callback + Nothing + +{-| NON PURE! + +Will create, **enqueue** and return a new process. + +-} +rawSpawn : Task err ok -> Process msg +rawSpawn task = + enqueue (Elm.Kernel.Scheduler.register + (Process + { id = Elm.Kernel.Sceduler.getGuid() + , root = Elm.Kernel.Basics.fudgeType task + , stack = [] + , mailbox = [] + } + ) + ) + + +{-| NON PURE! + +Send a message to a process and **enqueue** that process so that it +can perform actions based on the message. + +-} +rawSend : Process msg -> msg -> Process msg +rawSend (Process proc) msg = + enqueue (Elm.Kernel.Scheduler.register + (Process { proc | mailbox = proc.mailbox ++ [msg]}) + ) + + +{-| Create a task for that has a process deal with a message. +-} +send : Id msg -> msg -> Task x () +send processId msg = + binding + (\doneCallback -> + let + proc = + Elm.Kernel.Scheduler.getProcess processId + + _ = + Succeed (rawSend proc msg) + in + let + _ = + doneCallback (Succeed ()) + in + Nothing + ) + + +{-| Create a task that spawns a processes. +-} +spawn : Task err ok -> Task never (Id msg) +spawn task = + binding + (\doneCallback -> + let + (Process proc) = + rawSpawn task + + _ = + doneCallback (Succeed proc.id) + in + Nothing + ) + + +{-| Create a task kills a process. +-} +kill : Process msg -> Task x () +kill (Process { root }) = + binding + (\doneCallback -> + let + _ = case root of + Binding _ (Just (killer)) -> + let + (KillThunk thunk) = killer + in + thunk () + + _ -> + () + in + let + _ = + doneCallback (Succeed ()) + in + Nothing + ) + + +{-| NON PURE! + +Add a `Process` to the run queue and, unless this is a reenterant +call, drain the run queue but stepping all processes. +Returns the enqueued `Process`. + +-} +enqueue : Process msg -> Process msg +enqueue (Process process) = + let + _ = Elm.Kernel.Scheduler.enqueue stepper process.id + in + (Process process) + +-- Helper types -- + + +type Id msg = Id Never + + +type HiddenOk = HiddenOk Never + + +type HiddenErr = HiddenErr Never + + +type HiddenMsg = HiddenMsg Never + + +type KillThunk = KillThunk (() -> ()) + + +type alias BindingCallbackAlias err ok = + ((Task err ok -> ()) -> Maybe KillThunk) + + +type StackItem err ok + = StackSucceed (HiddenOk -> Task err ok) + | StackFail (HiddenErr-> Task err ok) + + +-- Helper functions -- + + +-- {-| NON PURE! +-- -} +-- rawStepper : Process -> Process +-- rawStepper (Process process) = +-- let +-- (doEnqueue, newProcess) = +-- stepper process + +-- _ = +-- if doEnqueue then +-- enqueue newProcess +-- else +-- newProcess +-- in +-- newProcess + + + +{-| NON PURE! + +This function **must** return a process with the **same ID** as +the process it is passed as an argument + +-} +stepper : Process msg -> Process msg +stepper (Process process) = + case process.root of + Succeed val -> + let + moveStackFowards stack = + case stack of + (StackFail _) :: rest -> + moveStackFowards rest + + (StackSucceed callback) :: rest -> + stepper (Process + { process + | root = callback val + , stack = rest + } + ) + + _ -> + (Process process) + + in + moveStackFowards process.stack + Fail error -> + let + moveStackFowards stack = + case stack of + (StackSucceed _) :: rest -> + moveStackFowards rest + + (StackFail callback) :: rest -> + stepper (Process + { process + | root = callback error + , stack = rest + } + ) + + _ -> + (Process process) + + in + moveStackFowards process.stack + Binding doEffect killer -> + let + newProcess = + { process + | root = killableRoot + } + + killableRoot = + Binding + (Debug.todo "put an assert(false) function here?") + (doEffect (\newRoot -> + let + -- todo: avoid enqueue here + _ = + enqueue + (Elm.Kernel.Scheduler.register + (Process { process | root = newRoot }) + ) + in + () + )) + in + Process newProcess + Receive callback -> + case process.mailbox of + [] -> + Process process + first :: rest -> + stepper + (Process + { process + | root = callback first + , mailbox = rest + } + ) + AndThen callback task -> + stepper + (Process + { process + | root = task + , stack = (StackSucceed callback) :: process.stack + } + ) + OnError callback task -> + stepper + (Process + { process + | root = task + , stack = (StackFail callback) :: process.stack + } + ) + + + + diff --git a/src/Process.elm b/src/Process.elm index 27ca23b5..94fa4bb9 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -81,7 +81,7 @@ come in a later release! -} spawn : Task x a -> Task y Id spawn = - Elm.Kernel.Scheduler.spawn + Scheduler.spawn {-| Block progress on the current process for the given number of milliseconds. @@ -102,5 +102,5 @@ flight, it will also abort the request. -} kill : Id -> Task x () kill = - Elm.Kernel.Scheduler.kill + Scheduler.kill From a3dd48b5210c1322f1f2d1f13fbb1ee7a6300368 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 24 Nov 2019 22:12:30 +0000 Subject: [PATCH 015/170] WIP: elm make works now nothing in kernel land is correct though --- README.md | 35 +--- elm.json | 6 +- src/Elm/Kernel/Platform.js | 61 +++++- src/Elm/Kernel/Process.js | 14 +- src/Elm/Kernel/Scheduler.js | 37 ++-- src/Platform.elm | 251 ++++++++++++++++++++++--- src/Platform/Bag.elm | 1 - src/Platform/RawScheduler.elm | 345 ++++++++++++++++++++++++++++++++++ src/Platform/Scheduler.elm | 340 ++++++++------------------------- src/Process.elm | 14 +- src/Task.elm | 14 +- 11 files changed, 769 insertions(+), 349 deletions(-) create mode 100644 src/Platform/RawScheduler.elm diff --git a/README.md b/README.md index 0a8cf2a2..d480ed7e 100644 --- a/README.md +++ b/README.md @@ -1,30 +1,15 @@ -# Core Libraries +# Elm-in-elm core libraries -Every Elm project needs this package! +> This repository currently contains a work in progress attempt to rewrite the elm core libraries into a form better suited for elm-in-elm. +> It has not yet been upstreamed or adopted by elm-in-elm; I hope one day to integrate this into elm-in-elm but currently is just my work. -It provides **basic functionality** like addition and subtraction as well as **data structures** like lists, dictionaries, and sets. +## Aims -> **New to Elm?** Go to [elm-lang.org](https://elm-lang.org) for an overview. +* Minimal amount of Kernel code. +* Easy to read. +## Rules -## Default Imports - -The modules in this package are so common, that some of them are imported by default in all Elm files. So it is as if every Elm file starts with these imports: - -```elm -import Basics exposing (..) -import List exposing (List, (::)) -import Maybe exposing (Maybe(..)) -import Result exposing (Result(..)) -import String exposing (String) -import Char exposing (Char) -import Tuple - -import Debug - -import Platform exposing ( Program ) -import Platform.Cmd as Cmd exposing ( Cmd ) -import Platform.Sub as Sub exposing ( Sub ) -``` - -The intention is to include things that are both extremely useful and very unlikely to overlap with anything that anyone will ever write in a library. By keeping the set of default imports relatively small, it also becomes easier to use whatever version of `map` suits your fancy. Finally, it makes it easier to figure out where the heck a function is coming from. +* Each kernel function may only be referenced by an elm definition of the same name. + Other elm functions **must** call the elm version of this function. +* Kernel functions may **not** call elm functions. diff --git a/elm.json b/elm.json index 745d7909..52f61b38 100644 --- a/elm.json +++ b/elm.json @@ -34,6 +34,8 @@ ] }, "elm-version": "0.19.0 <= v < 0.20.0", - "dependencies": {}, + "dependencies": { + "elm/json": "1.1.3 <= v < 2.0.0" + }, "test-dependencies": {} -} \ No newline at end of file +} diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 5cdee5dd..b8d5c58a 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -78,10 +78,69 @@ function _Platform_registerPreload(url) var _Platform_effectManagers = {}; +var _Platform_effectMangerFold = F2(function(func, initial) { + for (const key of Object.items(_Platform_effectManagers)) { + const info = _Platform_effectManagers[key]; + // TODO(harry) confirm this is valid + let effectTag; -function _Platform_setupEffects(managers, sendToApp) + if (info.__cmdMap === undefined) { + /**__DEBUG/ + effectTag = 'SubOnlyEffectModule'; + //*/ + + /**__PROD/ + effectTag = 0; + //*/ + } else { + if (info.__subMap === undefined) { + /**__DEBUG/ + effectTag = 'CmdOnlyEffectModule'; + //*/ + + /**__PROD/ + effectTag = 1; + //*/ + } else { + /**__DEBUG/ + effectTag = 'CmdAndSubEffectModule'; + //*/ + + /**__PROD/ + effectTag = 2; + //*/ + } + } + + const elmRecord = { + __$portSetup: info.__portSetup, + __$onSelfMsg: info.__onSelfMsg, + __$init: info.__init, + __$effects: { + $: effectTag, + a: { + __$onEffects: info.__onEffects, + __$cmdMap: info.__cmdMap, + __$subMap: info.__subMap + } + } + }; + + + initial = func( + key, + elmRecord, + initial + ); + } + return initial; +}); + + +function _Platform_setupEffects(sendToApp) { var ports; + let managers // setup all necessary effect managers for (var key in _Platform_effectManagers) diff --git a/src/Elm/Kernel/Process.js b/src/Elm/Kernel/Process.js index 4a750f32..178bc6f2 100644 --- a/src/Elm/Kernel/Process.js +++ b/src/Elm/Kernel/Process.js @@ -6,13 +6,11 @@ import Elm.Kernel.Utils exposing (Tuple0) */ -function _Process_sleep(time) +var _Process_delay = F3(function (time, value, callback) { - return __Scheduler_binding(function(callback) { - var id = setTimeout(function() { - callback(__Scheduler_succeed(__Utils_Tuple0)); - }, time); + var id = setTimeout(function() { + callback(value); + }, time); - return function() { clearTimeout(id); }; - }); -} + return function(x) { clearTimeout(id); return x; }; +}) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 8badd750..2bc5ec3d 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -145,29 +145,41 @@ function _Scheduler_receive(callback) var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); -function _Sceduler_getGuid() { +function _Scheduler_getGuid() { return Object.create({ id: _Scheduler_guid++ }); } -function _Sceduler_register(proc) { - _Scheduler_processes.set(proc.id, proc); - return proc; +function _Scheduler_getProcessState(id) { + const procState = _Scheduler_processes.get(id); + /**__DEBUG/ + if (procState === undefined) { + console.error(`INTERNAL ERROR: Process with id ${id} is not in map!`); + } + //*/ + return procState; } -function _Sceduler_getProcess(id) { - const proc = _Scheduler_processes.get(id); +function _Scheduler_updateProcessState(func, id) { + const procState = _Scheduler_getProcessState.get(id); + _Scheduler_processes.set(id, func(procState)); + return procState; +} + +function _Scheduler_registerNewProcess(procId, procState) { /**__DEBUG/ - if (proc === undefined) { - console.error(`INTERNAL ERROR: Process with id ${id} is not in map!`); + if (_Scheduler_processes.has(procId)) { + console.error(`INTERNAL ERROR: Process with id ${id} is already in map!`); } //*/ - return proc; + _Scheduler_processes.set(procId, procState); + return procId; } + var _Scheduler_working = false; var _Scheduler_queue = []; -var _Scheduler_enqueue = F2(function(stepper, procId) +var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) { _Scheduler_queue.push(procId); if (_Scheduler_working) @@ -177,10 +189,9 @@ var _Scheduler_enqueue = F2(function(stepper, procId) _Scheduler_working = true; while (procId = _Scheduler_queue.shift()) { - const process = _Scheduler_processes.get(procId); - newProcess = stepper(process); - _Scheduler_processes.set(procId, process); + stepper(procId); } _Scheduler_working = false; + return procId; }); diff --git a/src/Platform.elm b/src/Platform.elm index a3c9ff40..df5dadfa 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -1,6 +1,6 @@ module Platform exposing ( Program, worker - , Task, ProcessId + , Task(..), ProcessId(..) , Router, sendToApp, sendToSelf ) @@ -23,17 +23,33 @@ effect manager. Do you have an *organic need* this fills? Or are you just curious? Public discussions of your explorations should be framed accordingly. @docs Router, sendToApp, sendToSelf + +## Unresolve questions + +* Each app has a dict of effect mangers, it also has a dict of "mangers". + I have called these `OtherMangers` but what do they do and how shouuld they be named? + -} -import Basics exposing (Never) -import Elm.Kernel.Platform -import Platform.Scheduler as Scheduler -import Platform.Cmd exposing (Cmd) -import Platform.Sub exposing (Sub) -import Platform.Bag as Bag +import Basics exposing (..) +import List exposing ((::)) import Maybe exposing (Maybe(..)) +import Result exposing (Result(..)) +import String exposing (String) +import Char exposing (Char) +import Tuple +import Debug +import Platform.Cmd as Cmd exposing ( Cmd ) +import Platform.Sub as Sub exposing ( Sub ) + +import Elm.Kernel.Platform +import Platform.Bag as Bag +import Json.Decode exposing (Decoder) +import Json.Encode as Encode +import Dict exposing (Dict) +import Platform.RawScheduler as RawScheduler -- PROGRAMS @@ -41,7 +57,8 @@ import Maybe exposing (Maybe(..)) {-| A `Program` describes an Elm program! How does it react to input? Does it show anything on screen? Etc. -} -type Program flags model msg = Program +type Program flags model msg = + Program ((Decoder flags) -> DebugMetadata -> flags -> { ports: Encode.Value }) {-| Create a [headless][] program with no user interface. @@ -70,8 +87,15 @@ worker , subscriptions : model -> Sub msg } -> Program flags model msg -worker = - Elm.Kernel.Platform.worker +worker impl = + Program + (\flagsDecoder _ flags -> + initialize + flagsDecoder + flags + impl + (StepperBuilder (\ _ _ -> SendToApp (\ _ _ -> ()))) + ) @@ -82,13 +106,15 @@ worker = information on this. It is only defined here because it is a platform primitive. -} -type alias Task err ok = Scheduler.Task err ok +type Task err ok + = Task (RawScheduler.Task (Result err ok)) {-| Head over to the documentation for the [`Process`](Process) module for information on this. It is only defined here because it is a platform primitive. -} -type alias ProcessId = Scheduler.Id +type ProcessId = + ProcessId (RawScheduler.ProcessId Never) @@ -101,7 +127,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp: appMsg -> () - , selfProcess: ProcessId + , selfProcess: RawScheduler.ProcessId selfMsg } {-| Send the router a message for the main loop of your app. This message will @@ -109,17 +135,19 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Scheduler.binding - (\doneCallback -> - let - _ = - router.sendToApp msg - in + Task + (RawScheduler.binding + (\doneCallback -> let - _ = - doneCallback (Scheduler.Succeed ()) + _ = + router.sendToApp msg in - Nothing + let + _ = + doneCallback (RawScheduler.Value (Ok ())) + in + (\() -> ()) + ) ) @@ -131,6 +159,179 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Scheduler.send - router.selfProcess - (Bag.Self msg) + Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.send + router.selfProcess + msg + ) + ) + + + +-- HELPERS -- + +initialize : Decoder flags -> flags -> { init : flags -> ( model, Cmd msg ) + , update : msg -> model -> ( model, Cmd msg ) + , subscriptions : model -> Sub msg + } -> StepperBuilder model msg -> { ports : Encode.Value } +initialize flagDecoder flags { init, update, subscriptions } stepperBuilder = + Debug.todo "initialise app" +-- { +-- var managers = {}; +-- result = init(result.a); +-- var model = result.a; +-- var stepper = stepperBuilder(sendToApp, model); +-- var ports = _Platform_setupEffects(managers, sendToApp); + +-- function sendToApp(msg, viewMetadata) +-- { +-- result = A2(update, msg, model); +-- stepper(model = result.a, viewMetadata); +-- _Platform_dispatchEffects(managers, result.b, subscriptions(model)); +-- } + +-- _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + +-- return ports ? { ports: ports } : {}; +-- } + +-- effectManagerFold : List (String, EffectManager err state appMsg selfMsg) +effectManagerFold : (String -> EffectManager cmdLeafData subLeafData state appMsg selfMsg -> a -> a) -> a -> a +effectManagerFold = + Elm.Kernel.Platform.effectManagerFold + + +setupEffects : SendToApp appMsg -> (Dict String OutgoingPort, OtherManagers) +setupEffects sendToAppP = + effectManagerFold + (\key (EffectManager { portSetup } as effectManager) (ports, otherMangers) -> + ( case portSetup of + Just portSetupFunc -> + Dict.insert + key + (portSetupFunc key sendToAppP) + ports + + Nothing -> + ports + , Dict.insert + key + (instantiateEffectManger effectManager sendToAppP) + otherMangers + ) + ) + (Dict.empty, Dict.empty) + |> Tuple.mapSecond OtherManagers + +instantiateEffectManger : EffectManager cmdLeafData subLeafData state appMsg selfMsg -> SendToApp appMsg -> ProcessId +instantiateEffectManger (EffectManager effectManager) (SendToApp func) = + Debug.todo "instantiateEffectManger" + -- let + -- loop state = + -- RawScheduler.andThen + -- loop + -- (RawScheduler.Receive (\receivedData -> + -- case receivedData of + -- RawScheduler.Self value -> + -- effectManager.onSelfMsg router value state + + -- RawScheduler.Bag cmds subs -> + -- Debug.todo "send bags to effect manager" + -- -- case effectManger.effects of + -- -- CmdOnlyEffectModule { onEffects } -> + + + -- )) + + + -- (RawScheduler.Process selfProcess) = + -- RawScheduler.rawSpawn + -- (RawScheduler.andThen + -- (Debug.todo "mutal recursion needed") + -- effectManager.init + -- ) + -- router = + -- Router + -- { sendToApp = (\appMsg -> func appMsg AsyncUpdate) + -- , selfProcess = selfProcess.id + -- } + -- in + -- RawScheduler.Id2 (Elm.Kernel.Basics.fudgeType selfProcess.id) + +type SendToApp msg + = SendToApp (msg -> UpdateMetadate -> ()) + +type StepperBuilder model msg + = StepperBuilder (SendToApp msg -> model -> (SendToApp msg)) + +type alias DebugMetadata = Encode.Value + +type UpdateMetadate + = SyncUpdate + | AsyncUpdate + +type OtherManagers = + OtherManagers (Dict String ProcessId) + +type alias EffectMangerName = String + +{-| + +I try to avoid naff comments when writing code. Saying that, I do feel +compeled to remark on quite how nasty the following type definition is. +-} +type Effects cmdLeafData subLeafData state appMsg selfMsg + = CmdOnlyEffectModule + { onEffects: (Router appMsg selfMsg -> List cmdLeafData -> state -> Task Never state) + , cmdMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA cmdLeafData -> LeafDataOfTypeB cmdLeafData + } + | SubOnlyEffectModule + { onEffects: (Router appMsg selfMsg -> List subLeafData -> state -> Task Never state) + , subMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA subLeafData -> LeafDataOfTypeB subLeafData + } + | CmdAndSubEffectModule + { onEffects: (Router appMsg selfMsg -> List cmdLeafData -> List subLeafData -> state -> Task Never state) + , cmdMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA cmdLeafData -> LeafDataOfTypeB cmdLeafData + , subMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA subLeafData -> LeafDataOfTypeB subLeafData + } + +type EffectManager cmdLeafData subLeafData state appMsg selfMsg = + EffectManager + { portSetup : Maybe (EffectMangerName -> SendToApp selfMsg -> OutgoingPort) + , onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state + , init : Task Never state + , effects : Effects cmdLeafData subLeafData state appMsg selfMsg + , onEffects: (Router appMsg selfMsg -> List cmdLeafData -> List subLeafData -> state -> Task Never state) + , cmdMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA cmdLeafData -> LeafDataOfTypeB cmdLeafData + , subMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA subLeafData -> LeafDataOfTypeB subLeafData + } + + +type OutgoingPort = + OutgoingPort + { subscribe: (Encode.Value -> ()) + , unsubscribe: (Encode.Value -> ()) + } + +type HiddenTypeA + = HiddenTypeA Never + +type HiddenTypeB + = HiddenTypeB Never + +type LeafDataOfTypeA leafData + = LeafDataOfTypeA Never + +type LeafDataOfTypeB leafData + = LeafDataOfTypeB Never + +type UniqueId = UniqueId Never + +type HiddenErr = HiddenErr Never + + +type HiddenOk = HiddenOk Never + + diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index dd21bc96..1df44ea3 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -14,7 +14,6 @@ type Bag msg = Leaf -- let kernel code handle this one | Batch (List (Bag msg)) | Map (BagHiddenValue -> msg) (Bag BagHiddenValue) - | Self msg batch : List (Bag msg) -> Bag msg diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm new file mode 100644 index 00000000..eccc3a86 --- /dev/null +++ b/src/Platform/RawScheduler.elm @@ -0,0 +1,345 @@ +module Platform.RawScheduler exposing (..) + +{-| + +## Module notes: + +* Types called `HiddenXXX` are used to bypass the elm type system. + The programmer takes **full responsibiliy** for making sure + that the types line up. + That does mean you have to second guess any and all strange + decisions I have made, hopefully things will get clearer over + time. +- The `Binding` constructor on the `Task` type is tricky one. + + It contains a callback function (that we will call `doEffect`) + and a `killer` function. `doEffect` will be called by + `Scheduler.enqueue` and will be passed another callback. + We call this second callback `doneCallback`. + `doEffect` should do its effects (which may be impure) and then, + when it is done, call `doneCallback`.`doEffect` **must** call + `doneCallback` and it **must** pass `doneCallback` a + `Task ErrX OkX` as an argument. (I am unsure about the values of + ErrX and OkX at the moment). The return value of `doEffect` may + be either `undefined` or a function that cancels the effect. + + If the second value `killer` is not Nothing, then the runtime + will call it if the execution of the `Task` should be aborted. + + + +## Differences between this and offical elm/core + +* `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. +* `Process.stack` is an (immutable) js linked list in elm/core and an elm list here. +* `Elm.Kernel.Scheduler.rawSend` mutates the process before enqueuing it in elm/core. + Here we create a **new** process with the **same** (unique) id and then enqueue it. + Same applies for (non-raw) `send`. + +-} + +import Basics exposing (Never, Int, identity, (++), Bool(..)) +import Maybe exposing (Maybe(..)) +import Elm.Kernel.Basics +import Debug +import Platform.Bag exposing (Bag) +import List exposing ((::)) + +type Task val + = Value val + | AndThen (HiddenValA -> Task val) (Task val) + | AsyncAction (DoneCallback val -> TryAbortAction) TryAbortAction + + +type alias DoneCallback val = + Task val -> () + + +type alias TryAbortAction = + () -> () + +type ProcessState msg + = ProcessState + { root : Task HiddenValA + , stack : List (HiddenValB -> Task HiddenValC) + , mailbox : List msg + } + + +type ProcessId msg + = ProcessId + { id : UniqueId + , receiver : Maybe (msg -> Task HiddenValA) + } + + +type HiddenValA + = HiddenValA Never + + +type HiddenValB + = HiddenValB Never + + +type HiddenValC + = HiddenValC Never + + +type UniqueId = UniqueId Never + + +binding : (DoneCallback val -> TryAbortAction) -> Task val +binding callback = + AsyncAction + callback + identity + + +andThen : (a -> Task b) -> Task a -> Task b +andThen func task = + AndThen + (Elm.Kernel.Basics.fudgeType func) + (Elm.Kernel.Basics.fudgeType task) + +{-| NON PURE! + +Will create, **enqueue** and return a new process. + +-} +rawSpawn : Task a -> ProcessId never +rawSpawn task = + enqueue + (registerNewProcess + (ProcessId + { id = Elm.Kernel.Sceduler.getGuid() + , receiver = Nothing + } + ) + (ProcessState + { root = (Elm.Kernel.Basics.fudgeType task) + , mailbox = [] + , stack = [] + } + ) + ) + + +{-| NON PURE! + +Send a message to a process and **enqueue** that process so that it +can perform actions based on the message. + +-} +rawSend : ProcessId msg -> msg-> ProcessId msg +rawSend processId msg = + enqueue + (updateProcessState + (\(ProcessState procState) -> ProcessState { procState | mailbox = procState.mailbox ++ [msg]}) + processId + ) + + +{-| Create a task, if run, will make the process deal with a message. +-} +send : ProcessId msg -> msg -> Task () +send processId msg = + binding + (\doneCallback -> + let + _ = + rawSend processId msg + in + let + _ = + doneCallback (Value ()) + in + (\() -> ()) + ) + + +{-| Create a task that spawns a processes. +-} +spawn : Task a -> Task (ProcessId never) +spawn task = + binding + (\doneCallback -> + let + _ = + doneCallback (Value (rawSpawn task)) + in + (\() -> ()) + ) + + +{-| Create a task kills a process. +-} +kill : ProcessId msg -> Task () +kill processId = + let + (ProcessState { root }) = + getProcessState processId + in + binding + (\doneCallback -> + let + _ = case root of + AsyncAction _ killer -> + killer () + + _ -> + () + in + let + _ = + doneCallback (Value ()) + in + identity + ) + + +{-| NON PURE! + +Add a `Process` to the run queue and, unless this is a reenterant +call, drain the run queue but stepping all processes. +Returns the enqueued `Process`. + +-} +enqueue : ProcessId msg -> ProcessId msg +enqueue id = + enqueueWithStepper + (\procId -> + let + _ = + updateProcessState (stepper procId) procId + in + () + + ) + id + +-- Helper types -- + + + + +-- Helper functions -- + + +-- {-| NON PURE! +-- -} +-- rawStepper : Process -> Process +-- rawStepper (Process process) = +-- let +-- (doEnqueue, newProcess) = +-- stepper process + +-- _ = +-- if doEnqueue then +-- enqueue newProcess +-- else +-- newProcess +-- in +-- newProcess + + + +{-| NON PURE! + +This function **must** return a process with the **same ID** as +the process it is passed as an argument + +-} +stepper : ProcessId msg -> ProcessState msg -> ProcessState msg +stepper (ProcessId processId) (ProcessState process) = + let + (ProcessState steppedProcess) = + case process.root of + Value val -> + let + moveStackFowards stack = + case stack of + callback :: rest -> + stepper + (ProcessId processId) + (ProcessState + { process + | root = (Elm.Kernel.Basics.fudgeType (callback (Elm.Kernel.Basics.fudgeType val))) + , stack = rest + } + ) + + _ -> + (ProcessState process) + + in + moveStackFowards process.stack + AsyncAction doEffect killer -> + let + newProcess = + { process + | root = killableRoot + } + + killableRoot = + AsyncAction + (Debug.todo "put an assert(false) function here?") + (doEffect (\newRoot -> + let + -- todo: avoid enqueue here + _ = + enqueue + (Elm.Kernel.Scheduler.register + (ProcessState { process | root = newRoot }) + ) + in + () + )) + in + ProcessState newProcess + AndThen callback task -> + stepper + (ProcessId processId) + (ProcessState + { process + | root = task + , stack = (Elm.Kernel.Basics.fudgeType callback) :: process.stack + } + ) + in + case (steppedProcess.mailbox, processId.receiver) of + (first :: rest, Just receiver) -> + stepper + (ProcessId processId) + (ProcessState + { process + | root = receiver first + , mailbox = rest + } + ) + + ([], _) -> + ProcessState process + + (_, Nothing) -> + ProcessState process + + +-- Kernel function redefinitons -- + + +updateProcessState : (ProcessState msg -> ProcessState msg) -> ProcessId msg -> ProcessId msg +updateProcessState = + Elm.Kernel.Scheduler.updateProcessState + + +getProcessState : ProcessId msg -> ProcessState msg +getProcessState = + Elm.Kernel.Scheduler.getProcess + + +registerNewProcess : ProcessId msg -> ProcessState msg -> ProcessId msg +registerNewProcess = + Elm.Kernel.Scheduler.registerNewProcess + + +enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg +enqueueWithStepper = + Elm.Kernel.Scheduler.enqueue diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index ac869d36..112400d0 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -26,9 +26,6 @@ module Platform.Scheduler exposing (..) - - - ## Differences between this and offical elm/core * `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. @@ -39,294 +36,111 @@ module Platform.Scheduler exposing (..) -} -import Basics exposing (Never, Int, (++), Bool(..)) -import Maybe exposing (Maybe(..)) -import Elm.Kernel.Basics -import Debug -import List exposing ((::)) +import Platform +import Platform.RawScheduler as RawScheduler +import Result exposing (Result(..)) +import Basics exposing (Never) -type Task err ok - = Succeed ok - | Fail err - | Binding (BindingCallbackAlias err ok) (Maybe KillThunk) - -- todo binding callback type args - | AndThen (HiddenOk -> Task err ok) (Task err HiddenOk) - | OnError (HiddenErr -> Task err ok) (Task HiddenErr ok) - | Receive (HiddenMsg -> Task err ok) +type alias ProcessId msg + = RawScheduler.ProcessId msg -type Process msg - = Process - { id : Id msg - , root : Task HiddenErr HiddenOk - , stack : List (StackItem HiddenErr HiddenOk) - , mailbox : List msg - } +type alias DoneCallback err ok = + Platform.Task err ok -> () -binding : BindingCallbackAlias err ok -> Task err ok -binding callback = - Binding - callback - Nothing +type alias TryAbortAction = + RawScheduler.TryAbortAction -{-| NON PURE! -Will create, **enqueue** and return a new process. +succeed : ok -> Platform.Task never ok +succeed val = + Platform.Task (RawScheduler.Value (Ok val)) --} -rawSpawn : Task err ok -> Process msg -rawSpawn task = - enqueue (Elm.Kernel.Scheduler.register - (Process - { id = Elm.Kernel.Sceduler.getGuid() - , root = Elm.Kernel.Basics.fudgeType task - , stack = [] - , mailbox = [] - } - ) - ) +fail : err -> Platform.Task err never +fail e = + Platform.Task (RawScheduler.Value (Err e)) -{-| NON PURE! -Send a message to a process and **enqueue** that process so that it -can perform actions based on the message. +binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok +binding callback = + Platform.Task + (RawScheduler.binding + (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) + ) --} -rawSend : Process msg -> msg -> Process msg -rawSend (Process proc) msg = - enqueue (Elm.Kernel.Scheduler.register - (Process { proc | mailbox = proc.mailbox ++ [msg]}) - ) +andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 +andThen func (Platform.Task task) = + Platform.Task + (RawScheduler.andThen + (\r -> + case r of + Ok val -> + let + (Platform.Task rawTask) = + func val + in + rawTask -{-| Create a task for that has a process deal with a message. --} -send : Id msg -> msg -> Task x () -send processId msg = - binding - (\doneCallback -> - let - proc = - Elm.Kernel.Scheduler.getProcess processId - - _ = - Succeed (rawSend proc msg) - in - let - _ = - doneCallback (Succeed ()) - in - Nothing + Err e -> + RawScheduler.Value (Err e) + ) + task ) -{-| Create a task that spawns a processes. --} -spawn : Task err ok -> Task never (Id msg) -spawn task = - binding - (\doneCallback -> - let - (Process proc) = - rawSpawn task - - _ = - doneCallback (Succeed proc.id) - in - Nothing - ) - +onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok +onError func (Platform.Task task) = + Platform.Task + (RawScheduler.andThen + (\r -> + case r of + Ok val -> + RawScheduler.Value (Ok val) -{-| Create a task kills a process. --} -kill : Process msg -> Task x () -kill (Process { root }) = - binding - (\doneCallback -> - let - _ = case root of - Binding _ (Just (killer)) -> + Err e -> let - (KillThunk thunk) = killer + (Platform.Task rawTask) = + func e in - thunk () - - _ -> - () - in - let - _ = - doneCallback (Succeed ()) - in - Nothing + rawTask + ) + task ) -{-| NON PURE! - -Add a `Process` to the run queue and, unless this is a reenterant -call, drain the run queue but stepping all processes. -Returns the enqueued `Process`. - +{-| Create a task, if run, will make the process deal with a message. -} -enqueue : Process msg -> Process msg -enqueue (Process process) = - let - _ = Elm.Kernel.Scheduler.enqueue stepper process.id - in - (Process process) - --- Helper types -- - - -type Id msg = Id Never - - -type HiddenOk = HiddenOk Never - - -type HiddenErr = HiddenErr Never - - -type HiddenMsg = HiddenMsg Never - - -type KillThunk = KillThunk (() -> ()) - - -type alias BindingCallbackAlias err ok = - ((Task err ok -> ()) -> Maybe KillThunk) - - -type StackItem err ok - = StackSucceed (HiddenOk -> Task err ok) - | StackFail (HiddenErr-> Task err ok) - - --- Helper functions -- - - --- {-| NON PURE! --- -} --- rawStepper : Process -> Process --- rawStepper (Process process) = --- let --- (doEnqueue, newProcess) = --- stepper process - --- _ = --- if doEnqueue then --- enqueue newProcess --- else --- newProcess --- in --- newProcess - - - -{-| NON PURE! +send : ProcessId msg -> msg -> Platform.Task never () +send proc msg = + Platform.Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.send proc msg) + ) -This function **must** return a process with the **same ID** as -the process it is passed as an argument +{-| Create a task that spawns a processes. -} -stepper : Process msg -> Process msg -stepper (Process process) = - case process.root of - Succeed val -> - let - moveStackFowards stack = - case stack of - (StackFail _) :: rest -> - moveStackFowards rest - - (StackSucceed callback) :: rest -> - stepper (Process - { process - | root = callback val - , stack = rest - } - ) - - _ -> - (Process process) - - in - moveStackFowards process.stack - Fail error -> - let - moveStackFowards stack = - case stack of - (StackSucceed _) :: rest -> - moveStackFowards rest - - (StackFail callback) :: rest -> - stepper (Process - { process - | root = callback error - , stack = rest - } - ) - - _ -> - (Process process) - - in - moveStackFowards process.stack - Binding doEffect killer -> - let - newProcess = - { process - | root = killableRoot - } - - killableRoot = - Binding - (Debug.todo "put an assert(false) function here?") - (doEffect (\newRoot -> - let - -- todo: avoid enqueue here - _ = - enqueue - (Elm.Kernel.Scheduler.register - (Process { process | root = newRoot }) - ) - in - () - )) - in - Process newProcess - Receive callback -> - case process.mailbox of - [] -> - Process process - first :: rest -> - stepper - (Process - { process - | root = callback first - , mailbox = rest - } - ) - AndThen callback task -> - stepper - (Process - { process - | root = task - , stack = (StackSucceed callback) :: process.stack - } - ) - OnError callback task -> - stepper - (Process - { process - | root = task - , stack = (StackFail callback) :: process.stack - } - ) +spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId +spawn (Platform.Task task) = + Platform.Task + (RawScheduler.andThen + (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) + (RawScheduler.spawn task) + ) +{-| Create a task kills a process. +-} +kill : ProcessId msg -> Platform.Task never () +kill proc = + Platform.Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.kill proc) + ) diff --git a/src/Process.elm b/src/Process.elm index 94fa4bb9..95af0855 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -48,6 +48,7 @@ import Basics exposing (Float, Never) import Elm.Kernel.Scheduler import Elm.Kernel.Process import Platform +import Platform.Scheduler as Scheduler import Task exposing (Task) @@ -91,8 +92,8 @@ delay work until later. [setTimeout]: https://developer.mozilla.org/en-US/docs/Web/API/WindowTimers/setTimeout -} sleep : Float -> Task x () -sleep = - Elm.Kernel.Process.sleep +sleep time = + Scheduler.binding (delay time (Task.succeed ())) {-| Sometimes you `spawn` a process, but later decide it would be a waste to @@ -101,6 +102,11 @@ to bail on whatever task it is running. So if there is an HTTP request in flight, it will also abort the request. -} kill : Id -> Task x () -kill = - Scheduler.kill +kill (Platform.ProcessId proc) = + Scheduler.kill proc +-- KERNEL FUNCTIONS -- + +delay : Float -> Task err ok -> Scheduler.DoneCallback err ok -> Scheduler.TryAbortAction +delay = + Elm.Kernel.Process.delay diff --git a/src/Task.elm b/src/Task.elm index 1a9cbf7b..688950e6 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -26,11 +26,11 @@ HTTP requests or writing to a database. -} import Basics exposing (Never, (|>), (<<)) -import Elm.Kernel.Scheduler import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform import Platform.Cmd exposing (Cmd) +import Platform.Scheduler as Scheduler import Result exposing (Result(..)) @@ -77,7 +77,7 @@ type alias Task x a = -} succeed : a -> Task x a succeed = - Elm.Kernel.Scheduler.succeed + Scheduler.succeed {-| A task that fails immediately when run. Like with `succeed`, this can be @@ -91,7 +91,7 @@ used with `andThen` to check on the outcome of another task. -} fail : x -> Task x a fail = - Elm.Kernel.Scheduler.fail + Scheduler.fail @@ -206,7 +206,7 @@ First the process sleeps for an hour **and then** it tells us what time it is. -} andThen : (a -> Task x b) -> Task x a -> Task x b andThen = - Elm.Kernel.Scheduler.andThen + Scheduler.andThen @@ -226,7 +226,7 @@ callback to recover. -} onError : (x -> Task y a) -> Task x a -> Task y a onError = - Elm.Kernel.Scheduler.onError + Scheduler.onError {-| Transform the error value. This can be useful if you need a bunch of error @@ -343,9 +343,9 @@ onSelfMsg _ _ _ = succeed () -spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x () +spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x Platform.ProcessId spawnCmd router (Perform task) = - Elm.Kernel.Scheduler.spawn ( + Scheduler.spawn ( task |> andThen (Platform.sendToApp router) ) From 95b30dfa349894f0a3b459d137f802e35cab8777 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 7 Dec 2019 15:21:05 +0000 Subject: [PATCH 016/170] wip almost working --- custom-core.sh | 17 +- refresh.sh | 7 + src/Elm/Kernel/Platform.js | 575 ++++++++++--------------------- src/Elm/Kernel/Process.js | 16 - src/Elm/Kernel/Process.server.js | 11 - src/Elm/Kernel/Scheduler.js | 149 +------- src/Platform.elm | 511 +++++++++++++++++++-------- src/Platform/Bag.elm | 24 +- src/Platform/Cmd.elm | 53 ++- src/Platform/RawScheduler.elm | 73 +++- src/Platform/Scheduler.elm | 45 +-- src/Platform/Sub.elm | 51 ++- src/Process.elm | 14 +- 13 files changed, 737 insertions(+), 809 deletions(-) create mode 100755 refresh.sh delete mode 100644 src/Elm/Kernel/Process.js delete mode 100644 src/Elm/Kernel/Process.server.js diff --git a/custom-core.sh b/custom-core.sh index 8a678b03..9b63b49c 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -4,7 +4,7 @@ set -o errexit; set -o nounset; if [[ ! -v ELM_HOME ]]; then - eprintf "Please set ELM_HOME!" + printf "Please set ELM_HOME!" exit 1 fi @@ -12,27 +12,30 @@ printf "Sucess if ends with DONE: " ELM="${ELM:-elm}" ELM_VERSION="$($ELM --version)" -IFS=- read ELM_VERSION_START IGNORE <<< "$ELM_VERSION" +CORE_GIT_DIR=$(realpath .) + +echo CORE_GIT_DIR $CORE_GIT_DIR rm -rf "$ELM_HOME/$ELM_VERSION/packages/elm/core/" +cd $1 + if [[ ! -d elm-minimal-master ]]; then - curl -sL https://github.com/harrysarson/elm-minimal/archive/master.tar.gz | tar xz + git clone https://github.com/harrysarson/elm-minimal > /dev/null fi cd elm-minimal-master rm -rf elm-stuff +echo $(pwd) $ELM make src/Main.elm --output /dev/null > /dev/null || true; -cd - > /dev/null CORE_VERSION="$(ls $ELM_HOME/$ELM_VERSION/packages/elm/core/)" CORE_PACKAGE_DIR="$ELM_HOME/$ELM_VERSION/packages/elm/core/$CORE_VERSION" -CORE_GIT_DIR=$(realpath $1) - rm -rf "$CORE_PACKAGE_DIR" > /dev/null ln -sv "$CORE_GIT_DIR" "$CORE_PACKAGE_DIR" > /dev/null -rm -vf "${CORE_GIT_DIR}"/*.dat "${CORE_GIT_DIR}"/doc*.json > /dev/null + +./refresh.sh "$CORE_GIT_DIR" printf "DONE\n" diff --git a/refresh.sh b/refresh.sh new file mode 100755 index 00000000..9e89bc08 --- /dev/null +++ b/refresh.sh @@ -0,0 +1,7 @@ +#! /usr/bin/env bash + +set -o errexit; +set -o nounset; + +rm -vf "$1"/*.dat "$1"/doc*.json > /dev/null + diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index b8d5c58a..e48e4447 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -2,54 +2,70 @@ import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) -import Elm.Kernel.List exposing (Cons, Nil) -import Elm.Kernel.Process exposing (sleep) -import Elm.Kernel.Scheduler exposing (andThen, binding, rawSend, rawSpawn, receive, send, succeed) +import Elm.Kernel.List exposing (Nil) import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) */ +// State +var _Platform_outgoingPorts = {}; +var _Platform_incomingPorts = {}; +var _Platform_effectManagers = {}; +var _Platform_compiledEffectManagers = {}; -// PROGRAMS +// INITIALIZE A PROGRAM -var _Platform_worker = F4(function(impl, flagDecoder, debugMetadata, args) +function _Platform_initialize(flagDecoder, args, impl, functions) { - return _Platform_initialize( - flagDecoder, - args, - impl.__$init, - impl.__$update, - impl.__$subscriptions, - function() { return function() {} } - ); -}); - + // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value + // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a + const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); + if (!__Result_isOk(flagsResult)) { + __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); + } -// INITIALIZE A PROGRAM - + const managers = {}; + const ports = {}; + const initValue = impl.__$init(flagsResult.a); + var model = initValue.a; + const stepper = A2(functions.__$stepperBuilder, sendToApp, model); -function _Platform_initialize(flagDecoder, args, init, update, subscriptions, stepperBuilder) -{ - var result = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); - __Result_isOk(result) || __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); - var managers = {}; - result = init(result.a); - var model = result.a; - var stepper = stepperBuilder(sendToApp, model); - var ports = _Platform_setupEffects(managers, sendToApp); - - function sendToApp(msg, viewMetadata) + for (var key in _Platform_effectManagers) + { + const setup = _Platform_effectManagers[key]; + _Platform_compiledEffectManagers[key] = + setup(functions.__$setupEffects, sendToApp); + managers[key] = setup; + } + for (var key in _Platform_outgoingPorts) + { + const setup = _Platform_outgoingPorts[key]; + _Platform_compiledEffectManagers[key] = + setup(functions.__$setupOutgoingPort, sendToApp); + ports[key] = setup.ports; + managers[key] = setup.manger; + } + for (var key in _Platform_incomingPorts) { - result = A2(update, msg, model); - stepper(model = result.a, viewMetadata); - _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + const setup = _Platform_incomingPorts[key]; + _Platform_compiledEffectManagers[key] = + setup(functions.__$setupIncomingPort, sendToApp); + ports[key] = setup.ports; + managers[key] = setup.manger; } - _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + const sendToApp = F2((msg, viewMetadata) => { + const updateValue = A2(impl.__$update, msg, model); + model = updateValue.a + A2(stepper, model, viewMetadata); + A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); + }) + + A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); return ports ? { ports: ports } : {}; } @@ -76,443 +92,216 @@ function _Platform_registerPreload(url) // EFFECT MANAGERS -var _Platform_effectManagers = {}; - -var _Platform_effectMangerFold = F2(function(func, initial) { - for (const key of Object.items(_Platform_effectManagers)) { - const info = _Platform_effectManagers[key]; - // TODO(harry) confirm this is valid - let effectTag; - - if (info.__cmdMap === undefined) { - /**__DEBUG/ - effectTag = 'SubOnlyEffectModule'; - //*/ - - /**__PROD/ - effectTag = 0; - //*/ - } else { - if (info.__subMap === undefined) { - /**__DEBUG/ - effectTag = 'CmdOnlyEffectModule'; - //*/ - - /**__PROD/ - effectTag = 1; - //*/ - } else { - /**__DEBUG/ - effectTag = 'CmdAndSubEffectModule'; - //*/ - - /**__PROD/ - effectTag = 2; - //*/ - } - } - - const elmRecord = { - __$portSetup: info.__portSetup, - __$onSelfMsg: info.__onSelfMsg, - __$init: info.__init, - __$effects: { - $: effectTag, - a: { - __$onEffects: info.__onEffects, - __$cmdMap: info.__cmdMap, - __$subMap: info.__subMap - } - } - }; - - - initial = func( - key, - elmRecord, - initial - ); - } - return initial; -}); - - -function _Platform_setupEffects(sendToApp) -{ - var ports; - let managers - - // setup all necessary effect managers - for (var key in _Platform_effectManagers) - { - var manager = _Platform_effectManagers[key]; - if (manager.__portSetup) - { - ports = ports || {}; - ports[key] = manager.__portSetup(key, sendToApp); - } - - managers[key] = _Platform_instantiateManager(manager, sendToApp); - } - - return ports; +function _Platform_getEffectManager(name) { + return _Platform_compiledEffectManagers[name]; } - -function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) -{ - return { - __init: init, - __onEffects: onEffects, - __onSelfMsg: onSelfMsg, - __cmdMap: cmdMap, - __subMap: subMap - }; +function _Platform_effectManagerNameToString(name) { + return name; } -function _Platform_instantiateManager(info, sendToApp) +// Called by compiler generated js when creating event mangers +function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { - var router = { - __sendToApp: sendToApp, - __selfProcess: undefined - }; - - var onEffects = info.__onEffects; - var onSelfMsg = info.__onSelfMsg; - var cmdMap = info.__cmdMap; - var subMap = info.__subMap; - - function loop(state) - { - return A2(__Scheduler_andThen, loop, __Scheduler_receive(function(msg) - { - var value = msg.a; - + // TODO(harry) confirm this is valid + let fullOnEffects, fullCmdMap, fullSubMap; + if (cmdMap === undefined) { + // Subscription only effect module + fullOnEffects = F4(function(router, cmds, subs, state) { + return A3(onEffects, router, subs, state); + }); + fullCmdMap = F2(function(tagger, _val) { /**__DEBUG/ - if (msg.$ === 'Self') - //*/ - - /**__PROD/ - if (msg.$ === 3) + if (procState === undefined) { + console.error(`INTERNAL ERROR: attempt to map Cmd for subscription only effect module!`); + } //*/ - { - return A3(onSelfMsg, router, value, state); + }); + fullSubMap = subMap; + } else if (subMap === undefined) { + // Command only effect module + fullOnEffects = F4(function(router, cmds, subs, state) { + return A3(onEffects, router, cmds, state); + }); + fullCmdMap = cmdMap; + fullSubMap = F2(function(tagger, _val) { + /**__DEBUG/ + if (procState === undefined) { + console.error(`INTERNAL ERROR: attempt to map Sub for command only effect module!`); } - - return cmdMap && subMap - ? A4(onEffects, router, value.__cmds, value.__subs, state) - : A3(onEffects, router, cmdMap ? value.__cmds : value.__subs, state); - })); + //*/ + }); + } else { + fullOnEffects = onEffects; + fullCmdMap = cmdMap; + fullSubMap = subMap; } - - return router.__selfProcess = __Scheduler_rawSpawn(A2(__Scheduler_andThen, loop, info.__init)); + // Command **and** subscription event manager + return function(setup, sendToApp) { + return A6(setup, sendToApp, init, fullOnEffects, onSelfMsg, fullCmdMap, fullSubMap) + }; } - - -// ROUTING - - -var _Platform_sendToApp = F2(function(router, msg) -{ - return __Scheduler_binding(function(callback) - { - router.__sendToApp(msg); - callback(__Scheduler_succeed(__Utils_Tuple0)); - }, false); -}); - - -var _Platform_sendToSelf = F2(function(router, msg) -{ - return A2(__Scheduler_send, router.__selfProcess, { - /**__DEBUG/ - $: 'Value', - a: { - $: 'Self', - a: msg - } - //*/ - - /**__PROD/ - $: 3, - a: msg - //*/ - }); -}); - - - // BAGS -// Called by compiler generated js for event managers +/* Called by compiler generated js for event managers for the + * `command` or `subscription` function within an event manager + */ function _Platform_leaf(home) { return function(value) { /**__DEBUG/ return { - $: 'Value', + $: 'Data', a: { - $: 'Leaf', - __home: home, - __value: value + $: '::', + a: { + a: { + $: __1_EFFECTMANAGERNAME, + a: home + }, + b: { + $: __2_LEAFTYPE + a: value + }, + c: _Platform_compiledEffectManagers[home].__$cmdMap, + d: _Platform_compiledEffectManagers[home].__$subMap + b: { + $: '[]' + } } }; //*/ /**__PROD/ return { - $: 0, - __home: home, - __value: value + $: , + a: { + $: 1, + a: { + a: { + $: __1_EFFECTMANAGERNAME, + a: home + }, + b: { + $: __2_LEAFTYPE + a: value + }, + c: _Platform_compiledEffectManagers[home].__$cmdMap, + d: _Platform_compiledEffectManagers[home].__$subMap + b: { + $: 0 + } + } }; //*/ }; } -// PIPE BAGS INTO EFFECT MANAGERS - - -function _Platform_dispatchEffects(managers, cmdBag, subBag) -{ - var effectsDict = {}; - _Platform_gatherEffects(true, _Platform__unwrap_bag(cmdBag), effectsDict, null); - _Platform_gatherEffects(false, _Platform__unwrap_bag(subBag), effectsDict, null); - - for (var home in managers) - { - __Scheduler_rawSend(managers[home], { - $: 'fx', - a: effectsDict[home] || { __cmds: __List_Nil, __subs: __List_Nil } - }); - } -} - -function _Platform__unwrap_bag(cmdOrSub) -{ - /**__DEBUG/ - return cmdOrSub.a; - //*/ - - /**__PROD/ - return cmdOrSub; - //*/ -} - -function _Platform_gatherEffects(isCmd, bag, effectsDict, taggers) -{ - /**__DEBUG/ - const LEAF = 'Leaf'; - const BATCH = 'Batch'; - const MAP = 'Map'; - //*/ - - /**__PROD/ - const LEAF = 0; - const BATCH = 1; - const MAP = 2; - //*/ - switch (bag.$) - { - case LEAF: - var home = bag.__home; - var effect = _Platform_toEffect(isCmd, home, taggers, bag.__value); - effectsDict[home] = _Platform_insert(isCmd, effect, effectsDict[home]); - return; - - case BATCH: - for (let list = bag.a; list.b; list = list.b) // WHILE_CONS - { - _Platform_gatherEffects(isCmd, list.a, effectsDict, taggers); - } - return; - - case MAP: - _Platform_gatherEffects(isCmd, bag.b, effectsDict, { - __tagger: bag.a, - __rest: taggers - }); - return; - } -} - - -function _Platform_toEffect(isCmd, home, taggers, value) -{ - function applyTaggers(x) - { - for (var temp = taggers; temp; temp = temp.__rest) - { - x = temp.__tagger(x); - } - return x; - } - - var map = isCmd - ? _Platform_effectManagers[home].__cmdMap - : _Platform_effectManagers[home].__subMap; - - return A2(map, applyTaggers, value) -} - - -function _Platform_insert(isCmd, newEffect, effects) -{ - effects = effects || { __cmds: __List_Nil, __subs: __List_Nil }; - - isCmd - ? (effects.__cmds = __List_Cons(newEffect, effects.__cmds)) - : (effects.__subs = __List_Cons(newEffect, effects.__subs)); - - return effects; -} - - - // PORTS function _Platform_checkPortName(name) { - if (_Platform_effectManagers[name]) + if (_Platform_compiledEffectManagers[name]) { __Debug_crash(3, name) } } - -// OUTGOING PORTS - - function _Platform_outgoingPort(name, converter) { _Platform_checkPortName(name); - _Platform_effectManagers[name] = { - __cmdMap: _Platform_outgoingPortMap, - __converter: converter, - __portSetup: _Platform_setupOutgoingPort - }; - return _Platform_leaf(name); -} - - -var _Platform_outgoingPortMap = F2(function(tagger, value) { return value; }); - - -function _Platform_setupOutgoingPort(name) -{ - var subs = []; - var converter = _Platform_effectManagers[name].__converter; + _Platform_outgoingPorts[name] = function(setup, sendToApp) { + let subs = []; - // CREATE MANAGER - - var init = __Process_sleep(0); + function subscribe(callback) + { + subs.push(callback); + } - _Platform_effectManagers[name].__init = init; - _Platform_effectManagers[name].__onEffects = F3(function(router, cmdList, state) - { - for ( ; cmdList.b; cmdList = cmdList.b) // WHILE_CONS + function unsubscribe(callback) { - // grab a separate reference to subs in case unsubscribe is called - var currentSubs = subs; - var value = __Json_unwrap(converter(cmdList.a)); - for (var i = 0; i < currentSubs.length; i++) + // copy subs into a new array in case unsubscribe is called within a + // subscribed callback + subs = subs.slice(); + var index = subs.indexOf(callback); + if (index >= 0) { - currentSubs[i](value); + subs.splice(index, 1); } } - return init; - }); - // PUBLIC API + const outgoingPortSend = payload => { + var value = __Json_unwrap(payload); + for (const sub of subs) + { + sub(value); + } + return __Utils_Tuple0; + }; + - function subscribe(callback) - { - subs.push(callback); - } + const manager = A3( + setup, + sendToApp, + outgoingPortSend, + { + subscribe: subscribe, + unsubscribe: unsubscribe + }, + ); - function unsubscribe(callback) - { - // copy subs into a new array in case unsubscribe is called within a - // subscribed callback - subs = subs.slice(); - var index = subs.indexOf(callback); - if (index >= 0) - { - subs.splice(index, 1); + return { + ports: { + subscribe, + unsubscribe, + }, + manager, } } - return { - subscribe: subscribe, - unsubscribe: unsubscribe - }; + return _Platform_leaf(name) } - -// INCOMING PORTS - - function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - _Platform_effectManagers[name] = { - __subMap: _Platform_incomingPortMap, - __converter: converter, - __portSetup: _Platform_setupIncomingPort - }; - return _Platform_leaf(name); -} - - -var _Platform_incomingPortMap = F2(function(tagger, finalTagger) -{ - return function(value) - { - return tagger(finalTagger(value)); - }; -}); + _Platform_incomingPorts[name] = function(setup, sendToApp) { + let subs = __List_Nil; + function updateSubs(subsList) { + subs = subsList; + } -function _Platform_setupIncomingPort(name, sendToApp) -{ - var subs = __List_Nil; - var converter = _Platform_effectManagers[name].__converter; - - // CREATE MANAGER - - var init = __Scheduler_succeed(null); - - _Platform_effectManagers[name].__init = init; - _Platform_effectManagers[name].__onEffects = F3(function(router, subList, state) - { - subs = subList; - return init; - }); + const setupTuple = A2(setup, sendToApp, updateSubs); - // PUBLIC API + function send(incomingValue) + { + var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); - function send(incomingValue) - { - var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); + __Result_isOk(result) || __Debug_crash(4, name, result.a); - __Result_isOk(result) || __Debug_crash(4, name, result.a); + var value = result.a; + A2(setupTuple.b, value, subs); + } - var value = result.a; - for (var temp = subs; temp.b; temp = temp.b) // WHILE_CONS - { - sendToApp(temp.a(value)); + return { + ports: { + send, + }, + manager: setupTuple.a, } } - return { send: send }; + return _Platform_leaf(name) } diff --git a/src/Elm/Kernel/Process.js b/src/Elm/Kernel/Process.js deleted file mode 100644 index 178bc6f2..00000000 --- a/src/Elm/Kernel/Process.js +++ /dev/null @@ -1,16 +0,0 @@ -/* - -import Elm.Kernel.Scheduler exposing (binding, succeed) -import Elm.Kernel.Utils exposing (Tuple0) - -*/ - - -var _Process_delay = F3(function (time, value, callback) -{ - var id = setTimeout(function() { - callback(value); - }, time); - - return function(x) { clearTimeout(id); return x; }; -}) diff --git a/src/Elm/Kernel/Process.server.js b/src/Elm/Kernel/Process.server.js deleted file mode 100644 index 9230604a..00000000 --- a/src/Elm/Kernel/Process.server.js +++ /dev/null @@ -1,11 +0,0 @@ -/* - -import Elm.Kernel.Scheduler exposing (binding) - -*/ - - -function _Process_sleep() -{ - return __Scheduler_binding(function() {}); -} diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 2bc5ec3d..47e6f950 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -1,143 +1,3 @@ -/* - -import Elm.Kernel.Utils exposing (Tuple0) - -*/ - - -// TASKS - -function _Scheduler_succeed(value) -{ - /**__DEBUG/ - return { - $: 'Succeed', - a: value - }; - //*/ - - /**__PROD/ - return { - $: 0, - a: value - }; - //*/ -} - -function _Scheduler_fail(error) -{ - /**__DEBUG/ - return { - $: 'Fail', - a: error - }; - //*/ - - /**__PROD/ - return { - $: 1, - a: error - }; - //*/ -} - -function _Scheduler_binding(callback, killable) -{ - /**__DEBUG/ - return { - $: 'Binding', - a: killable - ? function(x) { - return { - $: 'Just', - a: callback(x), - }; - } - : function(x) { - callback(x); - return { - $: 'Nothing', - } - } - b: {$: 'Nothing'} - }; - //*/ - - /**__PROD/ - return { - $: 2, - a: killable - ? function(x) { - return { - $: 0, - a: callback(x), - }; - } - : function(x) { - callback(x); - return { - $: 1, - } - } - b: {$: 1} - }; - //*/ -} - -var _Scheduler_andThen = F2(function(callback, task) -{ - /**__DEBUG/ - return { - $: 'AndThen', - a: callback - b: task - }; - //*/ - - /**__PROD/ - return { - $: 3, - a: callback - b: task - }; - //*/ -}); - -var _Scheduler_onError = F2(function(callback, task) -{ - /**__DEBUG/ - return { - $: 'OnError', - a: callback - b: task - }; - //*/ - - /**__PROD/ - return { - $: 4, - a: callback - b: task - }; - //*/ -}); - -function _Scheduler_receive(callback) -{ - /**__DEBUG/ - return { - $: 'Receive', - a: callback - }; - //*/ - - /**__PROD/ - return { - $: 5, - a: callback - }; - //*/ -} // PROCESSES @@ -195,3 +55,12 @@ var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) return procId; }); + +var _Scheduler_delay = F3(function (time, value, callback) +{ + var id = setTimeout(function() { + callback(value); + }, time); + + return function(x) { clearTimeout(id); return x; }; +}) diff --git a/src/Platform.elm b/src/Platform.elm index df5dadfa..30565b8a 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -26,8 +26,8 @@ curious? Public discussions of your explorations should be framed accordingly. ## Unresolve questions -* Each app has a dict of effect mangers, it also has a dict of "mangers". - I have called these `OtherMangers` but what do they do and how shouuld they be named? +* Each app has a dict of effect managers, it also has a dict of "managers". + I have called these `OtherManagers` but what do they do and how shouuld they be named? -} @@ -41,16 +41,22 @@ import Tuple import Debug -import Platform.Cmd as Cmd exposing ( Cmd ) -import Platform.Sub as Sub exposing ( Sub ) +import Platform.Cmd as Cmd exposing ( Cmd(..) ) +import Platform.Sub as Sub exposing ( Sub(..) ) +import Elm.Kernel.Basics +import Elm.Kernel.Debug import Elm.Kernel.Platform import Platform.Bag as Bag -import Json.Decode exposing (Decoder) -import Json.Encode as Encode +-- import Json.Decode exposing (Decoder) +-- import Json.Encode as Encode import Dict exposing (Dict) import Platform.RawScheduler as RawScheduler + +type Decoder flags = Decoder (Decoder flags) +type EncodeValue = EncodeValue EncodeValue + -- PROGRAMS @@ -58,8 +64,17 @@ import Platform.RawScheduler as RawScheduler show anything on screen? Etc. -} type Program flags model msg = - Program ((Decoder flags) -> DebugMetadata -> flags -> { ports: Encode.Value }) - + Program ( + (Decoder flags) -> + DebugMetadata -> + RawJsObject { args: Maybe (RawJsObject flags) } -> + RawJsObject + { ports : RawJsObject + { outgoingPortName: OutgoingPort + , incomingPortName: IncomingPort + } + } + ) {-| Create a [headless][] program with no user interface. @@ -89,12 +104,17 @@ worker -> Program flags model msg worker impl = Program - (\flagsDecoder _ flags -> + (\flagsDecoder _ args -> initialize flagsDecoder - flags + args impl - (StepperBuilder (\ _ _ -> SendToApp (\ _ _ -> ()))) + { stepperBuilder = \ _ _ -> (\ _ _ -> ()) + , setupOutgoingPort = setupOutgoingPort + , setupIncomingPort = setupIncomingPort + , setupEffects = hiddenSetupEffects + , dispatchEffects = dispatchEffects + } ) @@ -109,6 +129,7 @@ primitive. type Task err ok = Task (RawScheduler.Task (Result err ok)) + {-| Head over to the documentation for the [`Process`](Process) module for information on this. It is only defined here because it is a platform primitive. @@ -136,7 +157,7 @@ be handled by the overall `update` function, just like events from `Html`. sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = Task - (RawScheduler.binding + (RawScheduler.async (\doneCallback -> let _ = @@ -169,150 +190,291 @@ sendToSelf (Router router) msg = ) +setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () msg Never +setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = + let + init = + Task (RawScheduler.Value (Ok ())) + + onSelfMsg _ selfMsg () = + never selfMsg + + execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) + execInOrder cmdList = + case cmdList of + first :: rest -> + RawScheduler.sync (\() -> + let + _ = outgoingPortSend first + in + execInOrder rest + ) + + _ -> + RawScheduler.Value (Ok ()) + + onEffects : Router msg selfMsg + -> List (HiddenMyCmd msg) + -> List (HiddenMySub msg) + -> () + -> Task Never () + onEffects _ cmdList _ () = + let + typedCmdList = Elm.Kernel.Basics.fudgeType cmdList + in + Task (execInOrder typedCmdList) + + in + EffectManager + { onSelfMsg = onSelfMsg + , init = init + , onEffects = onEffects + , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) + , subMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here + , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg + } + + +setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (EffectManager () msg Never, msg -> List (HiddenMySub msg) -> ()) +setupIncomingPort sendToApp2 updateSubs = + let + init = + Task (RawScheduler.Value (Ok ())) + + onSelfMsg _ selfMsg () = + never selfMsg + + onEffects _ _ subList () = + Task + (RawScheduler.sync + (\() -> + let + _ = updateSubs subList + in + RawScheduler.Value (Ok ()) + ) + ) + + onSend : msg -> List (HiddenMySub msg) -> () + onSend value subs = + let + typedSubs : List (msg -> msg) + typedSubs = + Elm.Kernel.Basics.fudgeType subs + in + + List.foldr + (\sub () -> sendToApp2 (sub value) AsyncUpdate) + () + typedSubs + + typedSubMap : (msg1 -> msg2) -> (a -> msg1) -> (a -> msg2) + typedSubMap tagger finalTagger = + (\val -> tagger (finalTagger val)) + + subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB + subMap tagger finalTagger = + Elm.Kernel.Basics.fudgeType typedSubMap + in + (EffectManager + { onSelfMsg = onSelfMsg + , init = init + , onEffects = onEffects + , cmdMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here + , subMap = subMap + , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg + } + , onSend + ) --- HELPERS -- -initialize : Decoder flags -> flags -> { init : flags -> ( model, Cmd msg ) - , update : msg -> model -> ( model, Cmd msg ) - , subscriptions : model -> Sub msg - } -> StepperBuilder model msg -> { ports : Encode.Value } -initialize flagDecoder flags { init, update, subscriptions } stepperBuilder = - Debug.todo "initialise app" --- { --- var managers = {}; --- result = init(result.a); --- var model = result.a; --- var stepper = stepperBuilder(sendToApp, model); --- var ports = _Platform_setupEffects(managers, sendToApp); - --- function sendToApp(msg, viewMetadata) --- { --- result = A2(update, msg, model); --- stepper(model = result.a, viewMetadata); --- _Platform_dispatchEffects(managers, result.b, subscriptions(model)); --- } - --- _Platform_dispatchEffects(managers, result.b, subscriptions(model)); - --- return ports ? { ports: ports } : {}; --- } - --- effectManagerFold : List (String, EffectManager err state appMsg selfMsg) -effectManagerFold : (String -> EffectManager cmdLeafData subLeafData state appMsg selfMsg -> a -> a) -> a -> a -effectManagerFold = - Elm.Kernel.Platform.effectManagerFold +-- HELPERS -- -setupEffects : SendToApp appMsg -> (Dict String OutgoingPort, OtherManagers) -setupEffects sendToAppP = - effectManagerFold - (\key (EffectManager { portSetup } as effectManager) (ports, otherMangers) -> - ( case portSetup of - Just portSetupFunc -> - Dict.insert - key - (portSetupFunc key sendToAppP) - ports - - Nothing -> - ports - , Dict.insert - key - (instantiateEffectManger effectManager sendToAppP) - otherMangers +dispatchEffects : OtherManagers msg -> Cmd msg -> Sub msg -> () +dispatchEffects (OtherManagers processes) cmd sub = + let + effectsDict = + Dict.empty + |> gatherCmds cmd + |> gatherSubs sub + in + Dict.foldr + (\key managerProc _ -> + let + (cmdList, subList) = + Maybe.withDefault + ([], []) + (Dict.get key effectsDict) + _ = + RawScheduler.rawSend + managerProc + (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) + in + () ) - ) - (Dict.empty, Dict.empty) - |> Tuple.mapSecond OtherManagers - -instantiateEffectManger : EffectManager cmdLeafData subLeafData state appMsg selfMsg -> SendToApp appMsg -> ProcessId -instantiateEffectManger (EffectManager effectManager) (SendToApp func) = - Debug.todo "instantiateEffectManger" - -- let - -- loop state = - -- RawScheduler.andThen - -- loop - -- (RawScheduler.Receive (\receivedData -> - -- case receivedData of - -- RawScheduler.Self value -> - -- effectManager.onSelfMsg router value state - - -- RawScheduler.Bag cmds subs -> - -- Debug.todo "send bags to effect manager" - -- -- case effectManger.effects of - -- -- CmdOnlyEffectModule { onEffects } -> - - - -- )) - - - -- (RawScheduler.Process selfProcess) = - -- RawScheduler.rawSpawn - -- (RawScheduler.andThen - -- (Debug.todo "mutal recursion needed") - -- effectManager.init - -- ) - -- router = - -- Router - -- { sendToApp = (\appMsg -> func appMsg AsyncUpdate) - -- , selfProcess = selfProcess.id - -- } - -- in - -- RawScheduler.Id2 (Elm.Kernel.Basics.fudgeType selfProcess.id) - -type SendToApp msg - = SendToApp (msg -> UpdateMetadate -> ()) - -type StepperBuilder model msg - = StepperBuilder (SendToApp msg -> model -> (SendToApp msg)) - -type alias DebugMetadata = Encode.Value - -type UpdateMetadate + () + processes + + +gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherCmds (Cmd.Data cmd) effectsDict = + cmd + |> List.foldr + (\{home, value} dict -> gatherHelper True home value dict) + effectsDict + + +gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherSubs (Sub.Data subs) effectsDict = + subs + |> List.foldr + (\{home, value} dict -> gatherHelper False home value dict) + effectsDict + + +gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherHelper isCmd home value effectsDict = + let + effectManager = + getEffectManager home + + + effect = + (Elm.Kernel.Basics.fudgeType value) + in + Dict.insert + (effectManagerNameToString home) + (createEffect isCmd effect (Dict.get (effectManagerNameToString home) effectsDict)) + effectsDict + + +createEffect : Bool -> Bag.LeafType msg -> Maybe (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> (List (Bag.LeafType msg), List (Bag.LeafType msg)) +createEffect isCmd newEffect maybeEffects = + let + (cmdList, subList) = + case maybeEffects of + Just effects -> effects + Nothing -> ([], []) + in + if isCmd then + (newEffect :: cmdList, subList) + else + (cmdList, newEffect :: subList) + + +setupEffects : SetupEffects state appMsg selfMsg +setupEffects sendToAppP init onEffects onSelfMsg cmdMap subMap = + EffectManager + { onSelfMsg = onSelfMsg + , init = init + , onEffects = onEffects + , cmdMap = cmdMap + , subMap = subMap + , selfProcess = instantiateEffectManager sendToAppP init onEffects onSelfMsg + } + +hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg +hiddenSetupEffects = + Elm.Kernel.Basics.fudgeType setupEffects + + +instantiateEffectManager : SendToApp appMsg + -> Task Never state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) + -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) +instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = + let + receiver msg state = + let + (Task task) = + case msg of + Self value -> + onSelfMsg router value state + + App cmds subs -> + onEffects router cmds subs state + in + RawScheduler.andThen + (\res -> + case res of + Ok val -> + RawScheduler.andThen + (\() -> RawScheduler.Value val) + (RawScheduler.sleep 0) + Err e -> never e + ) + task + + + selfProcess = + RawScheduler.rawSpawn ( + RawScheduler.andThen + (\() -> init) + (RawScheduler.sleep 0) + ) + + + router = + Router + { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) + , selfProcess = selfProcess + } + in + RawScheduler.rawSetReceiver selfProcess receiver + + +type alias SendToApp msg = + msg -> UpdateMetadata -> () + + +type alias StepperBuilder model msg = + SendToApp msg -> model -> (SendToApp msg) + + +type alias DebugMetadata = EncodeValue + + +{-| AsyncUpdate is default I think + +TODO(harry) understand this by reading source of VirtualDom +-} +type UpdateMetadata = SyncUpdate | AsyncUpdate -type OtherManagers = - OtherManagers (Dict String ProcessId) -type alias EffectMangerName = String +type OtherManagers appMsg = + OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) -{-| -I try to avoid naff comments when writing code. Saying that, I do feel -compeled to remark on quite how nasty the following type definition is. --} -type Effects cmdLeafData subLeafData state appMsg selfMsg - = CmdOnlyEffectModule - { onEffects: (Router appMsg selfMsg -> List cmdLeafData -> state -> Task Never state) - , cmdMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA cmdLeafData -> LeafDataOfTypeB cmdLeafData - } - | SubOnlyEffectModule - { onEffects: (Router appMsg selfMsg -> List subLeafData -> state -> Task Never state) - , subMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA subLeafData -> LeafDataOfTypeB subLeafData - } - | CmdAndSubEffectModule - { onEffects: (Router appMsg selfMsg -> List cmdLeafData -> List subLeafData -> state -> Task Never state) - , cmdMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA cmdLeafData -> LeafDataOfTypeB cmdLeafData - , subMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA subLeafData -> LeafDataOfTypeB subLeafData - } +type ReceivedData appMsg selfMsg + = Self selfMsg + | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) -type EffectManager cmdLeafData subLeafData state appMsg selfMsg = - EffectManager - { portSetup : Maybe (EffectMangerName -> SendToApp selfMsg -> OutgoingPort) - , onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state + +type EffectManager state appMsg selfMsg + = EffectManager + { onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state , init : Task Never state - , effects : Effects cmdLeafData subLeafData state appMsg selfMsg - , onEffects: (Router appMsg selfMsg -> List cmdLeafData -> List subLeafData -> state -> Task Never state) - , cmdMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA cmdLeafData -> LeafDataOfTypeB cmdLeafData - , subMap: (HiddenTypeA -> HiddenTypeA) -> LeafDataOfTypeA subLeafData -> LeafDataOfTypeB subLeafData + , onEffects: Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state + , cmdMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB + , subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB + , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) } type OutgoingPort = OutgoingPort - { subscribe: (Encode.Value -> ()) - , unsubscribe: (Encode.Value -> ()) + { subscribe: (EncodeValue -> ()) + , unsubscribe: (EncodeValue -> ()) + } + + +type IncomingPort = + IncomingPort + { send: (EncodeValue -> ()) } type HiddenTypeA @@ -321,17 +483,76 @@ type HiddenTypeA type HiddenTypeB = HiddenTypeB Never -type LeafDataOfTypeA leafData - = LeafDataOfTypeA Never -type LeafDataOfTypeB leafData - = LeafDataOfTypeB Never +type HiddenMyCmd msg = HiddenMyCmd Never + + +type HiddenMySub msg = HiddenMySub Never -type UniqueId = UniqueId Never -type HiddenErr = HiddenErr Never +type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg -type HiddenOk = HiddenOk Never +type HiddenState = HiddenState HiddenState +type RawJsObject record + = JsRecord (RawJsObject record) + | JsAny + + +type alias Impl flags model msg = + { init : flags -> ( model, Cmd msg ) + , update : msg -> model -> ( model, Cmd msg ) + , subscriptions : model -> Sub msg + } + + +type alias SetupEffects state appMsg selfMsg = + SendToApp appMsg + -> Task Never state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) + -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) + -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB) + -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB) + -> EffectManager state appMsg selfMsg + + +type alias InitFunctions model appMsg = + { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) + , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never + , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) + , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg + , dispatchEffects : OtherManagers appMsg -> Cmd appMsg -> Sub appMsg -> () + } + +-- kernel -- + +initialize : + Decoder flags -> + RawJsObject { args: Maybe (RawJsObject flags) } -> + Impl flags model msg -> + InitFunctions model msg -> + RawJsObject + { ports : RawJsObject + { outgoingPortName: OutgoingPort + , incomingPortName: IncomingPort + } + } +initialize = + Elm.Kernel.Platform.initialize + + +effectManagerNameToString : Bag.EffectManagerName -> String +effectManagerNameToString = + Elm.Kernel.Platform.effectManagerNameToString + + +getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg +getEffectManager = + Elm.Kernel.Platform.getEffectManager + + +effectManagerFold : (Bag.EffectManagerName -> EffectManager state appMsg selfMsg -> a -> a) -> a -> a +effectManagerFold = + Elm.Kernel.Platform.effectManagerFold diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index 1df44ea3..9c335012 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -1,28 +1,16 @@ module Platform.Bag exposing - ( Bag(..) - , batch - , map + ( LeafType + , EffectManagerName ) import Basics exposing (Never) +import String exposing (String) -{-| Generic bag type, for Cmds or Subs. -Any changes to this type definition need to be reflected in Elm/Kernel/Platform.js --} -type Bag msg - = Leaf -- let kernel code handle this one - | Batch (List (Bag msg)) - | Map (BagHiddenValue -> msg) (Bag BagHiddenValue) +type LeafType msg = LeafType Kernel -batch : List (Bag msg) -> Bag msg -batch bag = - Batch bag +type EffectManagerName = EffectManagerName Kernel -map : (a -> msg) -> Bag a -> Bag msg -map fn bag = - Map (Elm.Kernel.Basics.fudgeType fn) (Elm.Kernel.Basics.fudgeType bag) - -type BagHiddenValue = BagHiddenValue Never +type Kernel = Kernel Kernel diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 1ccf4445..23db2bbe 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -1,5 +1,5 @@ module Platform.Cmd exposing - ( Cmd + ( Cmd(..) , none , batch , map @@ -24,9 +24,10 @@ module Platform.Cmd exposing -} -import Platform.Bag -import Basics exposing ((>>)) +import Elm.Kernel.Basics +import Basics exposing (..) import List +import Platform.Bag as Bag @@ -46,9 +47,17 @@ ever, commands will make more sense as you work through [the Elm Architecture Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! -} -type Cmd msg = - Value (Platform.Bag.Bag msg) - +type Cmd msg + -- Constructor name **must** be same as that used in _Platform_leaf() and + -- the order of record fields **must** be the same too. + = Data + (List + { home : Bag.EffectManagerName + , value : (Bag.LeafType msg) + , cmdMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB + , subMapper : Never + } + ) {-| Tell the runtime that there are no commands. @@ -68,10 +77,9 @@ all do the same thing. -} batch : List (Cmd msg) -> Cmd msg batch = - List.map (\(Value bag) -> bag) - >> Platform.Bag.batch - >> Value - + List.map (\(Data cmd) -> cmd) + >> List.concat + >> Data -- FANCY STUFF @@ -86,5 +94,26 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Cmd a -> Cmd msg -map fn (Value bag) = - Value (Platform.Bag.map fn bag) +map fn (Data data) = + data + |> List.map + (\{home, value, cmdMapper, subMapper} -> + { home = home + , value = (fudgeCmdMapperType cmdMapper) fn value + , cmdMapper = cmdMapper + , subMapper = subMapper + } + ) + |> Data + +-- HELPERS -- + +type HiddenA = HiddenA Never + + +type HiddenB = HiddenB Never + + +fudgeCmdMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) +fudgeCmdMapperType = + Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index eccc3a86..1b9d552a 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -36,17 +36,18 @@ module Platform.RawScheduler exposing (..) -} -import Basics exposing (Never, Int, identity, (++), Bool(..)) +import Basics exposing (..) import Maybe exposing (Maybe(..)) import Elm.Kernel.Basics +import Elm.Kernel.Scheduler import Debug -import Platform.Bag exposing (Bag) import List exposing ((::)) type Task val = Value val | AndThen (HiddenValA -> Task val) (Task val) | AsyncAction (DoneCallback val -> TryAbortAction) TryAbortAction + | SyncAction (() -> Task val) type alias DoneCallback val = @@ -56,18 +57,18 @@ type alias DoneCallback val = type alias TryAbortAction = () -> () -type ProcessState msg +type ProcessState msg state = ProcessState - { root : Task HiddenValA + { root : Task state , stack : List (HiddenValB -> Task HiddenValC) , mailbox : List msg + , receiver : Maybe (msg -> Task state) } type ProcessId msg = ProcessId { id : UniqueId - , receiver : Maybe (msg -> Task HiddenValA) } @@ -86,13 +87,18 @@ type HiddenValC type UniqueId = UniqueId Never -binding : (DoneCallback val -> TryAbortAction) -> Task val -binding callback = +async : (DoneCallback val -> TryAbortAction) -> Task val +async callback = AsyncAction callback identity +sync : (() -> Task val) -> Task val +sync = + SyncAction + + andThen : (a -> Task b) -> Task a -> Task b andThen func task = AndThen @@ -110,18 +116,32 @@ rawSpawn task = (registerNewProcess (ProcessId { id = Elm.Kernel.Sceduler.getGuid() - , receiver = Nothing } ) (ProcessState { root = (Elm.Kernel.Basics.fudgeType task) , mailbox = [] , stack = [] + , receiver = Nothing } ) ) +{-| NON PURE! + +Will modify an existing process, **enqueue** and return it. + +-} +rawSetReceiver : ProcessId msg -> (msg -> a -> Task a) -> ProcessId msg +rawSetReceiver proc receiver = + enqueue + (updateProcessState + (\(ProcessState state) -> ProcessState { state | receiver = Just (Elm.Kernel.Basics.fudgeType receiver) } ) + proc + ) + + {-| NON PURE! Send a message to a process and **enqueue** that process so that it @@ -141,7 +161,7 @@ rawSend processId msg = -} send : ProcessId msg -> msg -> Task () send processId msg = - binding + async (\doneCallback -> let _ = @@ -159,7 +179,7 @@ send processId msg = -} spawn : Task a -> Task (ProcessId never) spawn task = - binding + async (\doneCallback -> let _ = @@ -168,6 +188,12 @@ spawn task = (\() -> ()) ) +{-| Create a task that sleeps for `time` milliseconds +-} +sleep : Float -> Task () +sleep time = + async (delay time (Value ())) + {-| Create a task kills a process. -} @@ -177,7 +203,7 @@ kill processId = (ProcessState { root }) = getProcessState processId in - binding + async (\doneCallback -> let _ = case root of @@ -247,7 +273,7 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId msg -> ProcessState msg -> ProcessState msg +stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state stepper (ProcessId processId) (ProcessState process) = let (ProcessState steppedProcess) = @@ -271,6 +297,7 @@ stepper (ProcessId processId) (ProcessState process) = in moveStackFowards process.stack + AsyncAction doEffect killer -> let newProcess = @@ -294,6 +321,16 @@ stepper (ProcessId processId) (ProcessState process) = )) in ProcessState newProcess + + SyncAction doEffect-> + let + newProcess = + { process + | root = doEffect () + } + in + ProcessState newProcess + AndThen callback task -> stepper (ProcessId processId) @@ -304,7 +341,7 @@ stepper (ProcessId processId) (ProcessState process) = } ) in - case (steppedProcess.mailbox, processId.receiver) of + case (steppedProcess.mailbox, steppedProcess.receiver) of (first :: rest, Just receiver) -> stepper (ProcessId processId) @@ -325,17 +362,17 @@ stepper (ProcessId processId) (ProcessState process) = -- Kernel function redefinitons -- -updateProcessState : (ProcessState msg -> ProcessState msg) -> ProcessId msg -> ProcessId msg +updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessId msg updateProcessState = Elm.Kernel.Scheduler.updateProcessState -getProcessState : ProcessId msg -> ProcessState msg +getProcessState : ProcessId msg -> ProcessState msg state getProcessState = Elm.Kernel.Scheduler.getProcess -registerNewProcess : ProcessId msg -> ProcessState msg -> ProcessId msg +registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess @@ -343,3 +380,7 @@ registerNewProcess = enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg enqueueWithStepper = Elm.Kernel.Scheduler.enqueue + +delay : Float -> Task val -> DoneCallback val -> TryAbortAction +delay = + Elm.Kernel.Scheduler.delay diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 112400d0..e89723c5 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -4,42 +4,15 @@ module Platform.Scheduler exposing (..) ## Module notes: -* Types called `HiddenXXX` are used to bypass the elm type system. - The programmer takes **full responsibiliy** for making sure - that the types line up. - That does mean you have to second guess any and all strange - decisions I have made, hopefully things will get clearer over - time. -- The `Binding` constructor on the `Task` type is tricky one. - + It contains a callback function (that we will call `doEffect`) - and a `killer` function. `doEffect` will be called by - `Scheduler.enqueue` and will be passed another callback. - We call this second callback `doneCallback`. - `doEffect` should do its effects (which may be impure) and then, - when it is done, call `doneCallback`.`doEffect` **must** call - `doneCallback` and it **must** pass `doneCallback` a - `Task ErrX OkX` as an argument. (I am unsure about the values of - ErrX and OkX at the moment). The return value of `doEffect` may - be either `undefined` or a function that cancels the effect. - + If the second value `killer` is not Nothing, then the runtime - will call it if the execution of the `Task` should be aborted. - - - -## Differences between this and offical elm/core - -* `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. -* `Process.stack` is an (immutable) js linked list in elm/core and an elm list here. -* `Elm.Kernel.Scheduler.rawSend` mutates the process before enqueuing it in elm/core. - Here we create a **new** process with the **same** (unique) id and then enqueue it. - Same applies for (non-raw) `send`. +TODO(harry) explain need for this module and how it relates to Platform and + Platform.RawScheduler. -} import Platform import Platform.RawScheduler as RawScheduler import Result exposing (Result(..)) -import Basics exposing (Never) +import Basics exposing (..) type alias ProcessId msg @@ -66,7 +39,7 @@ fail e = binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok binding callback = Platform.Task - (RawScheduler.binding + (RawScheduler.async (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) ) @@ -144,3 +117,13 @@ kill proc = (RawScheduler.kill proc) ) + +{-| Create a task that sleeps for `time` milliseconds +-} +sleep : Float -> Platform.Task x () +sleep time = + Platform.Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.sleep time) + ) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 0fcf7994..e36c25ea 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -1,5 +1,5 @@ module Platform.Sub exposing - ( Sub + ( Sub(..) , none , batch , map @@ -23,9 +23,10 @@ module Platform.Sub exposing @docs map -} -import Platform.Bag -import Basics exposing ((>>)) +import Elm.Kernel.Basics +import Basics exposing (..) import List +import Platform.Bag as Bag -- SUBSCRIPTIONS @@ -48,7 +49,17 @@ Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! -} type Sub msg - = Value (Platform.Bag.Bag msg) + -- Constructor name **must** be same as that used in _Platform_leaf() and + -- the order of record fields **must** be the same too. + = Data + (List + { home : Bag.EffectManagerName + , value : (Bag.LeafType msg) + , cmdMapper : Never + , subMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB + } + ) + {-| Tell the runtime that there are no subscriptions. @@ -66,9 +77,10 @@ subscriptions. -} batch : List (Sub msg) -> Sub msg batch = - List.map (\(Value bag) -> bag) - >> Platform.Bag.batch - >> Value + List.map (\(Data sub) -> sub) + >> List.concat + >> Data + @@ -84,5 +96,26 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Sub a -> Sub msg -map fn (Value bag) = - Value (Platform.Bag.map fn bag) +map fn (Data data) = + data + |> List.map + (\{home, value, cmdMapper, subMapper} -> + { home = home + , value = (fudgeSubMapperType subMapper) fn value + , cmdMapper = cmdMapper + , subMapper = subMapper + } + ) + |> Data + +-- HELPERS -- + +type HiddenA = HiddenA Never + + +type HiddenB = HiddenB Never + + +fudgeSubMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) +fudgeSubMapperType = + Elm.Kernel.Basics.fudgeType diff --git a/src/Process.elm b/src/Process.elm index 95af0855..c15a2fb4 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -44,9 +44,7 @@ the Elm community will be supportive of being more ambitious, even if it takes longer. That’s kind of what Elm is all about. -} -import Basics exposing (Float, Never) -import Elm.Kernel.Scheduler -import Elm.Kernel.Process +import Basics exposing (..) import Platform import Platform.Scheduler as Scheduler import Task exposing (Task) @@ -92,8 +90,8 @@ delay work until later. [setTimeout]: https://developer.mozilla.org/en-US/docs/Web/API/WindowTimers/setTimeout -} sleep : Float -> Task x () -sleep time = - Scheduler.binding (delay time (Task.succeed ())) +sleep = + Scheduler.sleep {-| Sometimes you `spawn` a process, but later decide it would be a waste to @@ -104,9 +102,3 @@ flight, it will also abort the request. kill : Id -> Task x () kill (Platform.ProcessId proc) = Scheduler.kill proc - --- KERNEL FUNCTIONS -- - -delay : Float -> Task err ok -> Scheduler.DoneCallback err ok -> Scheduler.TryAbortAction -delay = - Elm.Kernel.Process.delay From 6d6fa4638e60a299be01cc901fe8929d683e2cc4 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 7 Dec 2019 22:47:49 +0000 Subject: [PATCH 017/170] revert a lot of changes to try and compile --- src/Elm/Kernel/Basics.js | 45 +- src/Elm/Kernel/Bitwise.js | 39 + src/Elm/Kernel/Platform.js | 505 ++++++----- src/Elm/Kernel/Process.js | 18 + src/Elm/Kernel/Process.server.js | 11 + src/Elm/Kernel/Scheduler.js | 201 ++++- src/Platform.elm | 796 +++++++++--------- src/Platform/{Bag.elm => Bag} | 0 src/Platform/Cmd.elm | 59 +- .../{RawScheduler.elm => RawScheduler} | 0 src/Platform/Scheduler | 129 +++ src/Platform/Scheduler.elm | 129 --- src/Platform/Sub.elm | 59 +- src/Process.elm | 11 +- src/Task.elm | 15 +- tests/elm.json | 2 +- 16 files changed, 1193 insertions(+), 826 deletions(-) create mode 100644 src/Elm/Kernel/Bitwise.js create mode 100644 src/Elm/Kernel/Process.js create mode 100644 src/Elm/Kernel/Process.server.js rename src/Platform/{Bag.elm => Bag} (100%) rename src/Platform/{RawScheduler.elm => RawScheduler} (100%) create mode 100644 src/Platform/Scheduler delete mode 100644 src/Platform/Scheduler.elm diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index b8c33e63..049291f9 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -4,10 +4,35 @@ import Elm.Kernel.Debug exposing (crash) */ + // MATH +var _Basics_add = F2(function(a, b) { return a + b; }); +var _Basics_sub = F2(function(a, b) { return a - b; }); +var _Basics_mul = F2(function(a, b) { return a * b; }); +var _Basics_fdiv = F2(function(a, b) { return a / b; }); +var _Basics_idiv = F2(function(a, b) { return (a / b) | 0; }); var _Basics_pow = F2(Math.pow); +var _Basics_remainderBy = F2(function(b, a) { return a % b; }); + +// https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf +var _Basics_modBy = F2(function(modulus, x) +{ + var answer = x % modulus; + return modulus === 0 + ? __Debug_crash(11) + : + ((answer > 0 && modulus < 0) || (answer < 0 && modulus > 0)) + ? answer + modulus + : answer; +}); + + +// TRIGONOMETRY + +var _Basics_pi = Math.PI; +var _Basics_e = Math.E; var _Basics_cos = Math.cos; var _Basics_sin = Math.sin; var _Basics_tan = Math.tan; @@ -17,17 +42,23 @@ var _Basics_atan = Math.atan; var _Basics_atan2 = F2(Math.atan2); +// MORE MATH + +function _Basics_toFloat(x) { return x; } +function _Basics_truncate(n) { return n | 0; } +function _Basics_isInfinite(n) { return n === Infinity || n === -Infinity; } + var _Basics_ceiling = Math.ceil; var _Basics_floor = Math.floor; var _Basics_round = Math.round; var _Basics_sqrt = Math.sqrt; var _Basics_log = Math.log; +var _Basics_isNaN = isNaN; -var _Basics_modBy0 = function() -{ - __Debug_crash(11) -}; -var _Basics_fudgeType = function(x) { - return x; -}; +// BOOLEANS + +function _Basics_not(bool) { return !bool; } +var _Basics_and = F2(function(a, b) { return a && b; }); +var _Basics_or = F2(function(a, b) { return a || b; }); +var _Basics_xor = F2(function(a, b) { return a !== b; }); diff --git a/src/Elm/Kernel/Bitwise.js b/src/Elm/Kernel/Bitwise.js new file mode 100644 index 00000000..612e8c7c --- /dev/null +++ b/src/Elm/Kernel/Bitwise.js @@ -0,0 +1,39 @@ +/* + +*/ + + +var _Bitwise_and = F2(function(a, b) +{ + return a & b; +}); + +var _Bitwise_or = F2(function(a, b) +{ + return a | b; +}); + +var _Bitwise_xor = F2(function(a, b) +{ + return a ^ b; +}); + +function _Bitwise_complement(a) +{ + return ~a; +}; + +var _Bitwise_shiftLeftBy = F2(function(offset, a) +{ + return a << offset; +}); + +var _Bitwise_shiftRightBy = F2(function(offset, a) +{ + return a >> offset; +}); + +var _Bitwise_shiftRightZfBy = F2(function(offset, a) +{ + return a >>> offset; +}); diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index e48e4447..c1726550 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -2,70 +2,54 @@ import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) -import Elm.Kernel.List exposing (Nil) +import Elm.Kernel.List exposing (Cons, Nil) +import Elm.Kernel.Process exposing (sleep) +import Elm.Kernel.Scheduler exposing (andThen, binding, rawSend, rawSpawn, receive, send, succeed) import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) */ -// State -var _Platform_outgoingPorts = {}; -var _Platform_incomingPorts = {}; -var _Platform_effectManagers = {}; -var _Platform_compiledEffectManagers = {}; -// INITIALIZE A PROGRAM +// PROGRAMS -function _Platform_initialize(flagDecoder, args, impl, functions) +var _Platform_worker = F4(function(impl, flagDecoder, debugMetadata, args) { - // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value - // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a - const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); + return _Platform_initialize( + flagDecoder, + args, + impl.__$init, + impl.__$update, + impl.__$subscriptions, + function() { return function() {} } + ); +}); - if (!__Result_isOk(flagsResult)) { - __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); - } - const managers = {}; - const ports = {}; - const initValue = impl.__$init(flagsResult.a); - var model = initValue.a; - const stepper = A2(functions.__$stepperBuilder, sendToApp, model); - for (var key in _Platform_effectManagers) - { - const setup = _Platform_effectManagers[key]; - _Platform_compiledEffectManagers[key] = - setup(functions.__$setupEffects, sendToApp); - managers[key] = setup; - } - for (var key in _Platform_outgoingPorts) - { - const setup = _Platform_outgoingPorts[key]; - _Platform_compiledEffectManagers[key] = - setup(functions.__$setupOutgoingPort, sendToApp); - ports[key] = setup.ports; - managers[key] = setup.manger; - } - for (var key in _Platform_incomingPorts) +// INITIALIZE A PROGRAM + + +function _Platform_initialize(flagDecoder, args, init, update, subscriptions, stepperBuilder) +{ + var result = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); + __Result_isOk(result) || __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); + var managers = {}; + result = init(result.a); + var model = result.a; + var stepper = stepperBuilder(sendToApp, model); + var ports = _Platform_setupEffects(managers, sendToApp); + + function sendToApp(msg, viewMetadata) { - const setup = _Platform_incomingPorts[key]; - _Platform_compiledEffectManagers[key] = - setup(functions.__$setupIncomingPort, sendToApp); - ports[key] = setup.ports; - managers[key] = setup.manger; + result = A2(update, msg, model); + stepper(model = result.a, viewMetadata); + _Platform_dispatchEffects(managers, result.b, subscriptions(model)); } - const sendToApp = F2((msg, viewMetadata) => { - const updateValue = A2(impl.__$update, msg, model); - model = updateValue.a - A2(stepper, model, viewMetadata); - A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); - }) - - A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); + _Platform_dispatchEffects(managers, result.b, subscriptions(model)); return ports ? { ports: ports } : {}; } @@ -92,216 +76,353 @@ function _Platform_registerPreload(url) // EFFECT MANAGERS +var _Platform_effectManagers = {}; -function _Platform_getEffectManager(name) { - return _Platform_compiledEffectManagers[name]; -} -function _Platform_effectManagerNameToString(name) { - return name; +function _Platform_setupEffects(managers, sendToApp) +{ + var ports; + + // setup all necessary effect managers + for (var key in _Platform_effectManagers) + { + var manager = _Platform_effectManagers[key]; + + if (manager.__portSetup) + { + ports = ports || {}; + ports[key] = manager.__portSetup(key, sendToApp); + } + + managers[key] = _Platform_instantiateManager(manager, sendToApp); + } + + return ports; } -// Called by compiler generated js when creating event mangers function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { - // TODO(harry) confirm this is valid - let fullOnEffects, fullCmdMap, fullSubMap; - if (cmdMap === undefined) { - // Subscription only effect module - fullOnEffects = F4(function(router, cmds, subs, state) { - return A3(onEffects, router, subs, state); - }); - fullCmdMap = F2(function(tagger, _val) { - /**__DEBUG/ - if (procState === undefined) { - console.error(`INTERNAL ERROR: attempt to map Cmd for subscription only effect module!`); - } - //*/ - }); - fullSubMap = subMap; - } else if (subMap === undefined) { - // Command only effect module - fullOnEffects = F4(function(router, cmds, subs, state) { - return A3(onEffects, router, cmds, state); - }); - fullCmdMap = cmdMap; - fullSubMap = F2(function(tagger, _val) { - /**__DEBUG/ - if (procState === undefined) { - console.error(`INTERNAL ERROR: attempt to map Sub for command only effect module!`); + return { + __init: init, + __onEffects: onEffects, + __onSelfMsg: onSelfMsg, + __cmdMap: cmdMap, + __subMap: subMap + }; +} + + +function _Platform_instantiateManager(info, sendToApp) +{ + var router = { + __sendToApp: sendToApp, + __selfProcess: undefined + }; + + var onEffects = info.__onEffects; + var onSelfMsg = info.__onSelfMsg; + var cmdMap = info.__cmdMap; + var subMap = info.__subMap; + + function loop(state) + { + return A2(__Scheduler_andThen, loop, __Scheduler_receive(function(msg) + { + var value = msg.a; + + if (msg.$ === __2_SELF) + { + return A3(onSelfMsg, router, value, state); } - //*/ - }); - } else { - fullOnEffects = onEffects; - fullCmdMap = cmdMap; - fullSubMap = subMap; + + return cmdMap && subMap + ? A4(onEffects, router, value.__cmds, value.__subs, state) + : A3(onEffects, router, cmdMap ? value.__cmds : value.__subs, state); + })); } - // Command **and** subscription event manager - return function(setup, sendToApp) { - return A6(setup, sendToApp, init, fullOnEffects, onSelfMsg, fullCmdMap, fullSubMap) - }; + + return router.__selfProcess = __Scheduler_rawSpawn(A2(__Scheduler_andThen, loop, info.__init)); } + + +// ROUTING + + +var _Platform_sendToApp = F2(function(router, msg) +{ + return __Scheduler_binding(function(callback) + { + router.__sendToApp(msg); + callback(__Scheduler_succeed(__Utils_Tuple0)); + }); +}); + + +var _Platform_sendToSelf = F2(function(router, msg) +{ + return A2(__Scheduler_send, router.__selfProcess, { + $: __2_SELF, + a: msg + }); +}); + + + // BAGS -/* Called by compiler generated js for event managers for the - * `command` or `subscription` function within an event manager - */ function _Platform_leaf(home) { return function(value) { - /**__DEBUG/ return { - $: 'Data', - a: { - $: '::', - a: { - a: { - $: __1_EFFECTMANAGERNAME, - a: home - }, - b: { - $: __2_LEAFTYPE - a: value - }, - c: _Platform_compiledEffectManagers[home].__$cmdMap, - d: _Platform_compiledEffectManagers[home].__$subMap - b: { - $: '[]' - } - } + $: __2_LEAF, + __home: home, + __value: value }; - //*/ + }; +} - /**__PROD/ - return { - $: , - a: { - $: 1, - a: { - a: { - $: __1_EFFECTMANAGERNAME, - a: home - }, - b: { - $: __2_LEAFTYPE - a: value - }, - c: _Platform_compiledEffectManagers[home].__$cmdMap, - d: _Platform_compiledEffectManagers[home].__$subMap - b: { - $: 0 - } - } - }; - //*/ + +function _Platform_batch(list) +{ + return { + $: __2_NODE, + __bags: list }; } +var _Platform_map = F2(function(tagger, bag) +{ + return { + $: __2_MAP, + __func: tagger, + __bag: bag + } +}); + + + +// PIPE BAGS INTO EFFECT MANAGERS + + +function _Platform_dispatchEffects(managers, cmdBag, subBag) +{ + var effectsDict = {}; + _Platform_gatherEffects(true, cmdBag, effectsDict, null); + _Platform_gatherEffects(false, subBag, effectsDict, null); + + for (var home in managers) + { + __Scheduler_rawSend(managers[home], { + $: 'fx', + a: effectsDict[home] || { __cmds: __List_Nil, __subs: __List_Nil } + }); + } +} + + +function _Platform_gatherEffects(isCmd, bag, effectsDict, taggers) +{ + switch (bag.$) + { + case __2_LEAF: + var home = bag.__home; + var effect = _Platform_toEffect(isCmd, home, taggers, bag.__value); + effectsDict[home] = _Platform_insert(isCmd, effect, effectsDict[home]); + return; + + case __2_NODE: + for (var list = bag.__bags; list.b; list = list.b) // WHILE_CONS + { + _Platform_gatherEffects(isCmd, list.a, effectsDict, taggers); + } + return; + + case __2_MAP: + _Platform_gatherEffects(isCmd, bag.__bag, effectsDict, { + __tagger: bag.__func, + __rest: taggers + }); + return; + } +} + + +function _Platform_toEffect(isCmd, home, taggers, value) +{ + function applyTaggers(x) + { + for (var temp = taggers; temp; temp = temp.__rest) + { + x = temp.__tagger(x); + } + return x; + } + + var map = isCmd + ? _Platform_effectManagers[home].__cmdMap + : _Platform_effectManagers[home].__subMap; + + return A2(map, applyTaggers, value) +} + + +function _Platform_insert(isCmd, newEffect, effects) +{ + effects = effects || { __cmds: __List_Nil, __subs: __List_Nil }; + + isCmd + ? (effects.__cmds = __List_Cons(newEffect, effects.__cmds)) + : (effects.__subs = __List_Cons(newEffect, effects.__subs)); + + return effects; +} + + + // PORTS function _Platform_checkPortName(name) { - if (_Platform_compiledEffectManagers[name]) + if (_Platform_effectManagers[name]) { __Debug_crash(3, name) } } + +// OUTGOING PORTS + + function _Platform_outgoingPort(name, converter) { _Platform_checkPortName(name); - _Platform_outgoingPorts[name] = function(setup, sendToApp) { - let subs = []; + _Platform_effectManagers[name] = { + __cmdMap: _Platform_outgoingPortMap, + __converter: converter, + __portSetup: _Platform_setupOutgoingPort + }; + return _Platform_leaf(name); +} + + +var _Platform_outgoingPortMap = F2(function(tagger, value) { return value; }); - function subscribe(callback) - { - subs.push(callback); - } - function unsubscribe(callback) +function _Platform_setupOutgoingPort(name) +{ + var subs = []; + var converter = _Platform_effectManagers[name].__converter; + + // CREATE MANAGER + + var init = __Process_sleep(0); + + _Platform_effectManagers[name].__init = init; + _Platform_effectManagers[name].__onEffects = F3(function(router, cmdList, state) + { + for ( ; cmdList.b; cmdList = cmdList.b) // WHILE_CONS { - // copy subs into a new array in case unsubscribe is called within a - // subscribed callback - subs = subs.slice(); - var index = subs.indexOf(callback); - if (index >= 0) + // grab a separate reference to subs in case unsubscribe is called + var currentSubs = subs; + var value = __Json_unwrap(converter(cmdList.a)); + for (var i = 0; i < currentSubs.length; i++) { - subs.splice(index, 1); + currentSubs[i](value); } } + return init; + }); - const outgoingPortSend = payload => { - var value = __Json_unwrap(payload); - for (const sub of subs) - { - sub(value); - } - return __Utils_Tuple0; - }; + // PUBLIC API + function subscribe(callback) + { + subs.push(callback); + } - const manager = A3( - setup, - sendToApp, - outgoingPortSend, - { - subscribe: subscribe, - unsubscribe: unsubscribe - }, - ); - - return { - ports: { - subscribe, - unsubscribe, - }, - manager, + function unsubscribe(callback) + { + // copy subs into a new array in case unsubscribe is called within a + // subscribed callback + subs = subs.slice(); + var index = subs.indexOf(callback); + if (index >= 0) + { + subs.splice(index, 1); } } - return _Platform_leaf(name) + return { + subscribe: subscribe, + unsubscribe: unsubscribe + }; } + +// INCOMING PORTS + + function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - _Platform_incomingPorts[name] = function(setup, sendToApp) { - let subs = __List_Nil; + _Platform_effectManagers[name] = { + __subMap: _Platform_incomingPortMap, + __converter: converter, + __portSetup: _Platform_setupIncomingPort + }; + return _Platform_leaf(name); +} - function updateSubs(subsList) { - subs = subsList; - } - const setupTuple = A2(setup, sendToApp, updateSubs); +var _Platform_incomingPortMap = F2(function(tagger, finalTagger) +{ + return function(value) + { + return tagger(finalTagger(value)); + }; +}); - function send(incomingValue) - { - var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); - __Result_isOk(result) || __Debug_crash(4, name, result.a); +function _Platform_setupIncomingPort(name, sendToApp) +{ + var subs = __List_Nil; + var converter = _Platform_effectManagers[name].__converter; - var value = result.a; - A2(setupTuple.b, value, subs); - } + // CREATE MANAGER - return { - ports: { - send, - }, - manager: setupTuple.a, + var init = __Scheduler_succeed(null); + + _Platform_effectManagers[name].__init = init; + _Platform_effectManagers[name].__onEffects = F3(function(router, subList, state) + { + subs = subList; + return init; + }); + + // PUBLIC API + + function send(incomingValue) + { + var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); + + __Result_isOk(result) || __Debug_crash(4, name, result.a); + + var value = result.a; + for (var temp = subs; temp.b; temp = temp.b) // WHILE_CONS + { + sendToApp(temp.a(value)); } } - return _Platform_leaf(name) + return { send: send }; } diff --git a/src/Elm/Kernel/Process.js b/src/Elm/Kernel/Process.js new file mode 100644 index 00000000..4a750f32 --- /dev/null +++ b/src/Elm/Kernel/Process.js @@ -0,0 +1,18 @@ +/* + +import Elm.Kernel.Scheduler exposing (binding, succeed) +import Elm.Kernel.Utils exposing (Tuple0) + +*/ + + +function _Process_sleep(time) +{ + return __Scheduler_binding(function(callback) { + var id = setTimeout(function() { + callback(__Scheduler_succeed(__Utils_Tuple0)); + }, time); + + return function() { clearTimeout(id); }; + }); +} diff --git a/src/Elm/Kernel/Process.server.js b/src/Elm/Kernel/Process.server.js new file mode 100644 index 00000000..9230604a --- /dev/null +++ b/src/Elm/Kernel/Process.server.js @@ -0,0 +1,11 @@ +/* + +import Elm.Kernel.Scheduler exposing (binding) + +*/ + + +function _Process_sleep() +{ + return __Scheduler_binding(function() {}); +} diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 47e6f950..37a68be8 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -1,66 +1,195 @@ +/* + +import Elm.Kernel.Utils exposing (Tuple0) + +*/ + + +// TASKS + +function _Scheduler_succeed(value) +{ + return { + $: __1_SUCCEED, + __value: value + }; +} + +function _Scheduler_fail(error) +{ + return { + $: __1_FAIL, + __value: error + }; +} + +function _Scheduler_binding(callback) +{ + return { + $: __1_BINDING, + __callback: callback, + __kill: null + }; +} + +var _Scheduler_andThen = F2(function(callback, task) +{ + return { + $: __1_AND_THEN, + __callback: callback, + __task: task + }; +}); + +var _Scheduler_onError = F2(function(callback, task) +{ + return { + $: __1_ON_ERROR, + __callback: callback, + __task: task + }; +}); + +function _Scheduler_receive(callback) +{ + return { + $: __1_RECEIVE, + __callback: callback + }; +} // PROCESSES var _Scheduler_guid = 0; -var _Scheduler_processes = new WeakMap(); -function _Scheduler_getGuid() { - return Object.create({ id: _Scheduler_guid++ }); +function _Scheduler_rawSpawn(task) +{ + var proc = { + $: __2_PROCESS, + __id: _Scheduler_guid++, + __root: task, + __stack: null, + __mailbox: [] + }; + + _Scheduler_enqueue(proc); + + return proc; } -function _Scheduler_getProcessState(id) { - const procState = _Scheduler_processes.get(id); - /**__DEBUG/ - if (procState === undefined) { - console.error(`INTERNAL ERROR: Process with id ${id} is not in map!`); - } - //*/ - return procState; +function _Scheduler_spawn(task) +{ + return _Scheduler_binding(function(callback) { + callback(_Scheduler_succeed(_Scheduler_rawSpawn(task))); + }); } -function _Scheduler_updateProcessState(func, id) { - const procState = _Scheduler_getProcessState.get(id); - _Scheduler_processes.set(id, func(procState)); - return procState; +function _Scheduler_rawSend(proc, msg) +{ + proc.__mailbox.push(msg); + _Scheduler_enqueue(proc); } -function _Scheduler_registerNewProcess(procId, procState) { - /**__DEBUG/ - if (_Scheduler_processes.has(procId)) { - console.error(`INTERNAL ERROR: Process with id ${id} is already in map!`); - } - //*/ - _Scheduler_processes.set(procId, procState); - return procId; +var _Scheduler_send = F2(function(proc, msg) +{ + return _Scheduler_binding(function(callback) { + _Scheduler_rawSend(proc, msg); + callback(_Scheduler_succeed(__Utils_Tuple0)); + }); +}); + +function _Scheduler_kill(proc) +{ + return _Scheduler_binding(function(callback) { + var task = proc.__root; + if (task.$ === __1_BINDING && task.__kill) + { + task.__kill(); + } + + proc.__root = null; + + callback(_Scheduler_succeed(__Utils_Tuple0)); + }); } +/* STEP PROCESSES + +type alias Process = + { $ : tag + , id : unique_id + , root : Task + , stack : null | { $: SUCCEED | FAIL, a: callback, b: stack } + , mailbox : [msg] + } + +*/ + + var _Scheduler_working = false; var _Scheduler_queue = []; -var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) + +function _Scheduler_enqueue(proc) { - _Scheduler_queue.push(procId); + _Scheduler_queue.push(proc); if (_Scheduler_working) { return; } _Scheduler_working = true; - while (procId = _Scheduler_queue.shift()) + while (proc = _Scheduler_queue.shift()) { - stepper(procId); + _Scheduler_step(proc); } _Scheduler_working = false; - return procId; -}); +} -var _Scheduler_delay = F3(function (time, value, callback) +function _Scheduler_step(proc) { - var id = setTimeout(function() { - callback(value); - }, time); - - return function(x) { clearTimeout(id); return x; }; -}) + while (proc.__root) + { + var rootTag = proc.__root.$; + if (rootTag === __1_SUCCEED || rootTag === __1_FAIL) + { + while (proc.__stack && proc.__stack.$ !== rootTag) + { + proc.__stack = proc.__stack.__rest; + } + if (!proc.__stack) + { + return; + } + proc.__root = proc.__stack.__callback(proc.__root.__value); + proc.__stack = proc.__stack.__rest; + } + else if (rootTag === __1_BINDING) + { + proc.__root.__kill = proc.__root.__callback(function(newRoot) { + proc.__root = newRoot; + _Scheduler_enqueue(proc); + }); + return; + } + else if (rootTag === __1_RECEIVE) + { + if (proc.__mailbox.length === 0) + { + return; + } + proc.__root = proc.__root.__callback(proc.__mailbox.shift()); + } + else // if (rootTag === __1_AND_THEN || rootTag === __1_ON_ERROR) + { + proc.__stack = { + $: rootTag === __1_AND_THEN ? __1_SUCCEED : __1_FAIL, + __callback: proc.__root.__callback, + __rest: proc.__stack + }; + proc.__root = proc.__root.__task; + } + } +} diff --git a/src/Platform.elm b/src/Platform.elm index 30565b8a..1c39d76c 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -30,32 +30,37 @@ curious? Public discussions of your explorations should be framed accordingly. I have called these `OtherManagers` but what do they do and how shouuld they be named? -} - -import Basics exposing (..) -import List exposing ((::)) -import Maybe exposing (Maybe(..)) -import Result exposing (Result(..)) -import String exposing (String) -import Char exposing (Char) -import Tuple +import Basics exposing (Never) +import Elm.Kernel.Platform +import Elm.Kernel.Scheduler +import Platform.Cmd exposing (Cmd) +import Platform.Sub exposing (Sub) + +-- import Basics exposing (..) +-- import List exposing ((::)) +-- import Maybe exposing (Maybe(..)) +-- import Result exposing (Result(..)) +-- import String exposing (String) +-- import Char exposing (Char) +-- import Tuple import Debug -import Platform.Cmd as Cmd exposing ( Cmd(..) ) -import Platform.Sub as Sub exposing ( Sub(..) ) +-- import Platform.Cmd as Cmd exposing ( Cmd ) +-- import Platform.Sub as Sub exposing ( Sub ) -import Elm.Kernel.Basics -import Elm.Kernel.Debug -import Elm.Kernel.Platform -import Platform.Bag as Bag --- import Json.Decode exposing (Decoder) --- import Json.Encode as Encode -import Dict exposing (Dict) -import Platform.RawScheduler as RawScheduler +-- import Elm.Kernel.Basics +-- import Elm.Kernel.Debug +-- import Elm.Kernel.Platform +-- import Platform.Bag as Bag +-- -- import Json.Decode exposing (Decoder) +-- -- import Json.Encode as Encode +-- import Dict exposing (Dict) +-- import Platform.RawScheduler as RawScheduler -type Decoder flags = Decoder (Decoder flags) -type EncodeValue = EncodeValue EncodeValue +-- type Decoder flags = Decoder (Decoder flags) +-- type EncodeValue = EncodeValue EncodeValue -- PROGRAMS @@ -64,17 +69,17 @@ type EncodeValue = EncodeValue EncodeValue show anything on screen? Etc. -} type Program flags model msg = - Program ( - (Decoder flags) -> - DebugMetadata -> - RawJsObject { args: Maybe (RawJsObject flags) } -> - RawJsObject - { ports : RawJsObject - { outgoingPortName: OutgoingPort - , incomingPortName: IncomingPort - } - } - ) + Program + -- ((Decoder flags) -> + -- DebugMetadata -> + -- RawJsObject { args: Maybe (RawJsObject flags) } -> + -- RawJsObject + -- { ports : RawJsObject + -- { outgoingPortName: OutgoingPort + -- , incomingPortName: IncomingPort + -- } + -- } + -- ) {-| Create a [headless][] program with no user interface. @@ -102,20 +107,21 @@ worker , subscriptions : model -> Sub msg } -> Program flags model msg -worker impl = - Program - (\flagsDecoder _ args -> - initialize - flagsDecoder - args - impl - { stepperBuilder = \ _ _ -> (\ _ _ -> ()) - , setupOutgoingPort = setupOutgoingPort - , setupIncomingPort = setupIncomingPort - , setupEffects = hiddenSetupEffects - , dispatchEffects = dispatchEffects - } - ) +worker = + Debug.todo "worker" + -- Program + -- (\flagsDecoder _ args -> + -- initialize + -- flagsDecoder + -- args + -- impl + -- { stepperBuilder = \ _ _ -> (\ _ _ -> ()) + -- , setupOutgoingPort = setupOutgoingPort + -- , setupIncomingPort = setupIncomingPort + -- , setupEffects = hiddenSetupEffects + -- , dispatchEffects = dispatchEffects + -- } + -- ) @@ -127,7 +133,8 @@ information on this. It is only defined here because it is a platform primitive. -} type Task err ok - = Task (RawScheduler.Task (Result err ok)) + = Task + -- (RawScheduler.Task (Result err ok)) {-| Head over to the documentation for the [`Process`](Process) module for @@ -135,7 +142,8 @@ information on this. It is only defined here because it is a platform primitive. -} type ProcessId = - ProcessId (RawScheduler.ProcessId Never) + ProcessId + -- (RawScheduler.ProcessId Never) @@ -147,29 +155,30 @@ the main app and your individual effect manager. -} type Router appMsg selfMsg = Router - { sendToApp: appMsg -> () - , selfProcess: RawScheduler.ProcessId selfMsg - } + -- { sendToApp: appMsg -> () + -- , selfProcess: RawScheduler.ProcessId selfMsg + -- } {-| Send the router a message for the main loop of your app. This message will be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () -sendToApp (Router router) msg = - Task - (RawScheduler.async - (\doneCallback -> - let - _ = - router.sendToApp msg - in - let - _ = - doneCallback (RawScheduler.Value (Ok ())) - in - (\() -> ()) - ) - ) +sendToApp (Router) msg = + Debug.todo "sendToApp" + -- Task + -- (RawScheduler.async + -- (\doneCallback -> + -- let + -- _ = + -- router.sendToApp msg + -- in + -- let + -- _ = + -- doneCallback (RawScheduler.Value (Ok ())) + -- in + -- (\() -> ()) + -- ) + -- ) {-| Send the router a message for your effect manager. This message will @@ -179,380 +188,381 @@ effect manager as necessary. As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () -sendToSelf (Router router) msg = - Task - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.send - router.selfProcess - msg - ) - ) - - -setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () msg Never -setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = - let - init = - Task (RawScheduler.Value (Ok ())) - - onSelfMsg _ selfMsg () = - never selfMsg - - execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) - execInOrder cmdList = - case cmdList of - first :: rest -> - RawScheduler.sync (\() -> - let - _ = outgoingPortSend first - in - execInOrder rest - ) - - _ -> - RawScheduler.Value (Ok ()) - - onEffects : Router msg selfMsg - -> List (HiddenMyCmd msg) - -> List (HiddenMySub msg) - -> () - -> Task Never () - onEffects _ cmdList _ () = - let - typedCmdList = Elm.Kernel.Basics.fudgeType cmdList - in - Task (execInOrder typedCmdList) - - in - EffectManager - { onSelfMsg = onSelfMsg - , init = init - , onEffects = onEffects - , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) - , subMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here - , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg - } - - -setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (EffectManager () msg Never, msg -> List (HiddenMySub msg) -> ()) -setupIncomingPort sendToApp2 updateSubs = - let - init = - Task (RawScheduler.Value (Ok ())) - - onSelfMsg _ selfMsg () = - never selfMsg - - onEffects _ _ subList () = - Task - (RawScheduler.sync - (\() -> - let - _ = updateSubs subList - in - RawScheduler.Value (Ok ()) - ) - ) - - onSend : msg -> List (HiddenMySub msg) -> () - onSend value subs = - let - typedSubs : List (msg -> msg) - typedSubs = - Elm.Kernel.Basics.fudgeType subs - in - - List.foldr - (\sub () -> sendToApp2 (sub value) AsyncUpdate) - () - typedSubs - - typedSubMap : (msg1 -> msg2) -> (a -> msg1) -> (a -> msg2) - typedSubMap tagger finalTagger = - (\val -> tagger (finalTagger val)) - - subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB - subMap tagger finalTagger = - Elm.Kernel.Basics.fudgeType typedSubMap - in - (EffectManager - { onSelfMsg = onSelfMsg - , init = init - , onEffects = onEffects - , cmdMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here - , subMap = subMap - , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg - } - , onSend - ) +sendToSelf (Router) msg = + Debug.todo "sendToSelf" + -- Task + -- (RawScheduler.andThen + -- (\() -> RawScheduler.Value (Ok ())) + -- (RawScheduler.send + -- router.selfProcess + -- msg + -- ) + -- ) + + +-- setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () msg Never +-- setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = +-- let +-- init = +-- Task (RawScheduler.Value (Ok ())) + +-- onSelfMsg _ selfMsg () = +-- never selfMsg + +-- execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) +-- execInOrder cmdList = +-- case cmdList of +-- first :: rest -> +-- RawScheduler.sync (\() -> +-- let +-- _ = outgoingPortSend first +-- in +-- execInOrder rest +-- ) + +-- _ -> +-- RawScheduler.Value (Ok ()) + +-- onEffects : Router msg selfMsg +-- -> List (HiddenMyCmd msg) +-- -> List (HiddenMySub msg) +-- -> () +-- -> Task Never () +-- onEffects _ cmdList _ () = +-- let +-- typedCmdList = Elm.Kernel.Basics.fudgeType cmdList +-- in +-- Task (execInOrder typedCmdList) + +-- in +-- EffectManager +-- { onSelfMsg = onSelfMsg +-- , init = init +-- , onEffects = onEffects +-- , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) +-- , subMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here +-- , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg +-- } + + +-- setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (EffectManager () msg Never, msg -> List (HiddenMySub msg) -> ()) +-- setupIncomingPort sendToApp2 updateSubs = +-- let +-- init = +-- Task (RawScheduler.Value (Ok ())) + +-- onSelfMsg _ selfMsg () = +-- never selfMsg + +-- onEffects _ _ subList () = +-- Task +-- (RawScheduler.sync +-- (\() -> +-- let +-- _ = updateSubs subList +-- in +-- RawScheduler.Value (Ok ()) +-- ) +-- ) + +-- onSend : msg -> List (HiddenMySub msg) -> () +-- onSend value subs = +-- let +-- typedSubs : List (msg -> msg) +-- typedSubs = +-- Elm.Kernel.Basics.fudgeType subs +-- in + +-- List.foldr +-- (\sub () -> sendToApp2 (sub value) AsyncUpdate) +-- () +-- typedSubs + +-- typedSubMap : (msg1 -> msg2) -> (a -> msg1) -> (a -> msg2) +-- typedSubMap tagger finalTagger = +-- (\val -> tagger (finalTagger val)) + +-- subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB +-- subMap tagger finalTagger = +-- Elm.Kernel.Basics.fudgeType typedSubMap +-- in +-- (EffectManager +-- { onSelfMsg = onSelfMsg +-- , init = init +-- , onEffects = onEffects +-- , cmdMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here +-- , subMap = subMap +-- , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg +-- } +-- , onSend +-- ) + + + +-- -- HELPERS -- + +-- dispatchEffects : OtherManagers msg -> Cmd msg -> Sub msg -> () +-- dispatchEffects (OtherManagers processes) cmd sub = +-- let +-- effectsDict = +-- Dict.empty +-- |> gatherCmds cmd +-- |> gatherSubs sub +-- in +-- Dict.foldr +-- (\key managerProc _ -> +-- let +-- (cmdList, subList) = +-- Maybe.withDefault +-- ([], []) +-- (Dict.get key effectsDict) +-- _ = +-- RawScheduler.rawSend +-- managerProc +-- (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) +-- in +-- () +-- ) +-- () +-- processes + + +-- gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +-- gatherCmds (Cmd.Data cmd) effectsDict = +-- cmd +-- |> List.foldr +-- (\{home, value} dict -> gatherHelper True home value dict) +-- effectsDict + + +-- gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +-- gatherSubs (Sub.Data subs) effectsDict = +-- subs +-- |> List.foldr +-- (\{home, value} dict -> gatherHelper False home value dict) +-- effectsDict + + +-- gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +-- gatherHelper isCmd home value effectsDict = +-- let +-- effectManager = +-- getEffectManager home + + +-- effect = +-- (Elm.Kernel.Basics.fudgeType value) +-- in +-- Dict.insert +-- (effectManagerNameToString home) +-- (createEffect isCmd effect (Dict.get (effectManagerNameToString home) effectsDict)) +-- effectsDict + + +-- createEffect : Bool -> Bag.LeafType msg -> Maybe (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> (List (Bag.LeafType msg), List (Bag.LeafType msg)) +-- createEffect isCmd newEffect maybeEffects = +-- let +-- (cmdList, subList) = +-- case maybeEffects of +-- Just effects -> effects +-- Nothing -> ([], []) +-- in +-- if isCmd then +-- (newEffect :: cmdList, subList) +-- else +-- (cmdList, newEffect :: subList) + + +-- setupEffects : SetupEffects state appMsg selfMsg +-- setupEffects sendToAppP init onEffects onSelfMsg cmdMap subMap = +-- EffectManager +-- { onSelfMsg = onSelfMsg +-- , init = init +-- , onEffects = onEffects +-- , cmdMap = cmdMap +-- , subMap = subMap +-- , selfProcess = instantiateEffectManager sendToAppP init onEffects onSelfMsg +-- } + +-- hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg +-- hiddenSetupEffects = +-- Elm.Kernel.Basics.fudgeType setupEffects + + +-- instantiateEffectManager : SendToApp appMsg +-- -> Task Never state +-- -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) +-- -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) +-- -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) +-- instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = +-- let +-- receiver msg state = +-- let +-- (Task task) = +-- case msg of +-- Self value -> +-- onSelfMsg router value state + +-- App cmds subs -> +-- onEffects router cmds subs state +-- in +-- RawScheduler.andThen +-- (\res -> +-- case res of +-- Ok val -> +-- RawScheduler.andThen +-- (\() -> RawScheduler.Value val) +-- (RawScheduler.sleep 0) +-- Err e -> never e +-- ) +-- task - --- HELPERS -- - -dispatchEffects : OtherManagers msg -> Cmd msg -> Sub msg -> () -dispatchEffects (OtherManagers processes) cmd sub = - let - effectsDict = - Dict.empty - |> gatherCmds cmd - |> gatherSubs sub - in - Dict.foldr - (\key managerProc _ -> - let - (cmdList, subList) = - Maybe.withDefault - ([], []) - (Dict.get key effectsDict) - _ = - RawScheduler.rawSend - managerProc - (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) - in - () - ) - () - processes - - -gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherCmds (Cmd.Data cmd) effectsDict = - cmd - |> List.foldr - (\{home, value} dict -> gatherHelper True home value dict) - effectsDict - - -gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherSubs (Sub.Data subs) effectsDict = - subs - |> List.foldr - (\{home, value} dict -> gatherHelper False home value dict) - effectsDict - - -gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherHelper isCmd home value effectsDict = - let - effectManager = - getEffectManager home - - - effect = - (Elm.Kernel.Basics.fudgeType value) - in - Dict.insert - (effectManagerNameToString home) - (createEffect isCmd effect (Dict.get (effectManagerNameToString home) effectsDict)) - effectsDict - - -createEffect : Bool -> Bag.LeafType msg -> Maybe (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> (List (Bag.LeafType msg), List (Bag.LeafType msg)) -createEffect isCmd newEffect maybeEffects = - let - (cmdList, subList) = - case maybeEffects of - Just effects -> effects - Nothing -> ([], []) - in - if isCmd then - (newEffect :: cmdList, subList) - else - (cmdList, newEffect :: subList) - - -setupEffects : SetupEffects state appMsg selfMsg -setupEffects sendToAppP init onEffects onSelfMsg cmdMap subMap = - EffectManager - { onSelfMsg = onSelfMsg - , init = init - , onEffects = onEffects - , cmdMap = cmdMap - , subMap = subMap - , selfProcess = instantiateEffectManager sendToAppP init onEffects onSelfMsg - } - -hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg -hiddenSetupEffects = - Elm.Kernel.Basics.fudgeType setupEffects - - -instantiateEffectManager : SendToApp appMsg - -> Task Never state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) - -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) -instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = - let - receiver msg state = - let - (Task task) = - case msg of - Self value -> - onSelfMsg router value state - - App cmds subs -> - onEffects router cmds subs state - in - RawScheduler.andThen - (\res -> - case res of - Ok val -> - RawScheduler.andThen - (\() -> RawScheduler.Value val) - (RawScheduler.sleep 0) - Err e -> never e - ) - task +-- selfProcess = +-- RawScheduler.rawSpawn ( +-- RawScheduler.andThen +-- (\() -> init) +-- (RawScheduler.sleep 0) +-- ) - selfProcess = - RawScheduler.rawSpawn ( - RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) - ) +-- router = +-- Router +-- { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) +-- , selfProcess = selfProcess +-- } +-- in +-- RawScheduler.rawSetReceiver selfProcess receiver - router = - Router - { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) - , selfProcess = selfProcess - } - in - RawScheduler.rawSetReceiver selfProcess receiver +-- type alias SendToApp msg = +-- msg -> UpdateMetadata -> () -type alias SendToApp msg = - msg -> UpdateMetadata -> () +-- type alias StepperBuilder model msg = +-- SendToApp msg -> model -> (SendToApp msg) -type alias StepperBuilder model msg = - SendToApp msg -> model -> (SendToApp msg) +-- type alias DebugMetadata = EncodeValue -type alias DebugMetadata = EncodeValue +-- {-| AsyncUpdate is default I think +-- TODO(harry) understand this by reading source of VirtualDom +-- -} +-- type UpdateMetadata +-- = SyncUpdate +-- | AsyncUpdate -{-| AsyncUpdate is default I think -TODO(harry) understand this by reading source of VirtualDom --} -type UpdateMetadata - = SyncUpdate - | AsyncUpdate - - -type OtherManagers appMsg = - OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) +-- type OtherManagers appMsg = +-- OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) -type ReceivedData appMsg selfMsg - = Self selfMsg - | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) +-- type ReceivedData appMsg selfMsg +-- = Self selfMsg +-- | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) -type EffectManager state appMsg selfMsg - = EffectManager - { onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state - , init : Task Never state - , onEffects: Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state - , cmdMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB - , subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB - , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) - } +-- type EffectManager state appMsg selfMsg +-- = EffectManager +-- { onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state +-- , init : Task Never state +-- , onEffects: Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state +-- , cmdMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB +-- , subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB +-- , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) +-- } -type OutgoingPort = - OutgoingPort - { subscribe: (EncodeValue -> ()) - , unsubscribe: (EncodeValue -> ()) - } +-- type OutgoingPort = +-- OutgoingPort +-- { subscribe: (EncodeValue -> ()) +-- , unsubscribe: (EncodeValue -> ()) +-- } -type IncomingPort = - IncomingPort - { send: (EncodeValue -> ()) - } +-- type IncomingPort = +-- IncomingPort +-- { send: (EncodeValue -> ()) +-- } -type HiddenTypeA - = HiddenTypeA Never +-- type HiddenTypeA +-- = HiddenTypeA Never -type HiddenTypeB - = HiddenTypeB Never +-- type HiddenTypeB +-- = HiddenTypeB Never -type HiddenMyCmd msg = HiddenMyCmd Never +-- type HiddenMyCmd msg = HiddenMyCmd Never -type HiddenMySub msg = HiddenMySub Never +-- type HiddenMySub msg = HiddenMySub Never -type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg +-- type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg -type HiddenState = HiddenState HiddenState +-- type HiddenState = HiddenState HiddenState -type RawJsObject record - = JsRecord (RawJsObject record) - | JsAny +-- type RawJsObject record +-- = JsRecord (RawJsObject record) +-- | JsAny -type alias Impl flags model msg = - { init : flags -> ( model, Cmd msg ) - , update : msg -> model -> ( model, Cmd msg ) - , subscriptions : model -> Sub msg - } +-- type alias Impl flags model msg = +-- { init : flags -> ( model, Cmd msg ) +-- , update : msg -> model -> ( model, Cmd msg ) +-- , subscriptions : model -> Sub msg +-- } -type alias SetupEffects state appMsg selfMsg = - SendToApp appMsg - -> Task Never state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) - -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB) - -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB) - -> EffectManager state appMsg selfMsg +-- type alias SetupEffects state appMsg selfMsg = +-- SendToApp appMsg +-- -> Task Never state +-- -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) +-- -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) +-- -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB) +-- -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB) +-- -> EffectManager state appMsg selfMsg -type alias InitFunctions model appMsg = - { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) - , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never - , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) - , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg - , dispatchEffects : OtherManagers appMsg -> Cmd appMsg -> Sub appMsg -> () - } +-- type alias InitFunctions model appMsg = +-- { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) +-- , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never +-- , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) +-- , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg +-- , dispatchEffects : OtherManagers appMsg -> Cmd appMsg -> Sub appMsg -> () +-- } --- kernel -- +-- -- kernel -- -initialize : - Decoder flags -> - RawJsObject { args: Maybe (RawJsObject flags) } -> - Impl flags model msg -> - InitFunctions model msg -> - RawJsObject - { ports : RawJsObject - { outgoingPortName: OutgoingPort - , incomingPortName: IncomingPort - } - } -initialize = - Elm.Kernel.Platform.initialize +-- initialize : +-- Decoder flags -> +-- RawJsObject { args: Maybe (RawJsObject flags) } -> +-- Impl flags model msg -> +-- InitFunctions model msg -> +-- RawJsObject +-- { ports : RawJsObject +-- { outgoingPortName: OutgoingPort +-- , incomingPortName: IncomingPort +-- } +-- } +-- initialize = +-- Elm.Kernel.Platform.initialize -effectManagerNameToString : Bag.EffectManagerName -> String -effectManagerNameToString = - Elm.Kernel.Platform.effectManagerNameToString +-- effectManagerNameToString : Bag.EffectManagerName -> String +-- effectManagerNameToString = +-- Elm.Kernel.Platform.effectManagerNameToString -getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg -getEffectManager = - Elm.Kernel.Platform.getEffectManager +-- getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg +-- getEffectManager = +-- Elm.Kernel.Platform.getEffectManager -effectManagerFold : (Bag.EffectManagerName -> EffectManager state appMsg selfMsg -> a -> a) -> a -> a -effectManagerFold = - Elm.Kernel.Platform.effectManagerFold +-- effectManagerFold : (Bag.EffectManagerName -> EffectManager state appMsg selfMsg -> a -> a) -> a -> a +-- effectManagerFold = +-- Elm.Kernel.Platform.effectManagerFold diff --git a/src/Platform/Bag.elm b/src/Platform/Bag similarity index 100% rename from src/Platform/Bag.elm rename to src/Platform/Bag diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 23db2bbe..29745cd4 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -1,5 +1,5 @@ module Platform.Cmd exposing - ( Cmd(..) + ( Cmd , none , batch , map @@ -24,10 +24,11 @@ module Platform.Cmd exposing -} -import Elm.Kernel.Basics +-- import Elm.Kernel.Basics import Basics exposing (..) import List -import Platform.Bag as Bag +import Debug +-- import Platform.Bag as Bag @@ -50,14 +51,14 @@ fit into a real application! type Cmd msg -- Constructor name **must** be same as that used in _Platform_leaf() and -- the order of record fields **must** be the same too. - = Data - (List - { home : Bag.EffectManagerName - , value : (Bag.LeafType msg) - , cmdMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB - , subMapper : Never - } - ) + = Cmd + -- (List + -- { home : Bag.EffectManagerName + -- , value : (Bag.LeafType msg) + -- , cmdMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB + -- , subMapper : Never + -- } + -- ) {-| Tell the runtime that there are no commands. @@ -77,9 +78,10 @@ all do the same thing. -} batch : List (Cmd msg) -> Cmd msg batch = - List.map (\(Data cmd) -> cmd) - >> List.concat - >> Data + Debug.todo "batch" + -- List.map (\(Data cmd) -> cmd) + -- >> List.concat + -- >> Data -- FANCY STUFF @@ -94,17 +96,18 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Cmd a -> Cmd msg -map fn (Data data) = - data - |> List.map - (\{home, value, cmdMapper, subMapper} -> - { home = home - , value = (fudgeCmdMapperType cmdMapper) fn value - , cmdMapper = cmdMapper - , subMapper = subMapper - } - ) - |> Data +map fn _ = + Debug.todo "map" + -- data + -- |> List.map + -- (\{home, value, cmdMapper, subMapper} -> + -- { home = home + -- , value = (fudgeCmdMapperType cmdMapper) fn value + -- , cmdMapper = cmdMapper + -- , subMapper = subMapper + -- } + -- ) + -- |> Data -- HELPERS -- @@ -114,6 +117,6 @@ type HiddenA = HiddenA Never type HiddenB = HiddenB Never -fudgeCmdMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) -fudgeCmdMapperType = - Elm.Kernel.Basics.fudgeType +-- fudgeCmdMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) +-- fudgeCmdMapperType = +-- Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler similarity index 100% rename from src/Platform/RawScheduler.elm rename to src/Platform/RawScheduler diff --git a/src/Platform/Scheduler b/src/Platform/Scheduler new file mode 100644 index 00000000..5aa78c64 --- /dev/null +++ b/src/Platform/Scheduler @@ -0,0 +1,129 @@ +module Platform.Scheduler exposing (..) + +{-| + +## Module notes: + +TODO(harry) explain need for this module and how it relates to Platform and + Platform.RawScheduler. + +-} + +import Platform +import Platform.RawScheduler as RawScheduler +import Result exposing (Result(..)) +import Basics exposing (..) + + +type alias ProcessId msg + = RawScheduler.ProcessId msg + +-- type alias DoneCallback err ok = +-- Platform.Task err ok -> () + + +-- type alias TryAbortAction = +-- RawScheduler.TryAbortAction + + +-- succeed : ok -> Platform.Task never ok +-- succeed val = +-- Platform.Task (RawScheduler.Value (Ok val)) + + +-- fail : err -> Platform.Task err never +-- fail e = +-- Platform.Task (RawScheduler.Value (Err e)) + + +-- binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok +-- binding callback = +-- Platform.Task +-- (RawScheduler.async +-- (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) +-- ) + + +-- andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 +-- andThen func (Platform.Task task) = +-- Platform.Task +-- (RawScheduler.andThen +-- (\r -> +-- case r of +-- Ok val -> +-- let +-- (Platform.Task rawTask) = +-- func val +-- in +-- rawTask + +-- Err e -> +-- RawScheduler.Value (Err e) +-- ) +-- task +-- ) + + +-- onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok +-- onError func (Platform.Task task) = +-- Platform.Task +-- (RawScheduler.andThen +-- (\r -> +-- case r of +-- Ok val -> +-- RawScheduler.Value (Ok val) + +-- Err e -> +-- let +-- (Platform.Task rawTask) = +-- func e +-- in +-- rawTask +-- ) +-- task +-- ) + + +-- {-| Create a task, if run, will make the process deal with a message. +-- -} +-- send : ProcessId msg -> msg -> Platform.Task never () +-- send proc msg = +-- Platform.Task +-- (RawScheduler.andThen +-- (\() -> RawScheduler.Value (Ok ())) +-- (RawScheduler.send proc msg) +-- ) + + +-- {-| Create a task that spawns a processes. +-- -} +-- spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId +-- spawn (Platform.Task task) = +-- Platform.Task +-- (RawScheduler.andThen +-- (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) +-- (RawScheduler.spawn task) +-- ) + + + +-- {-| Create a task kills a process. +-- -} +-- kill : ProcessId msg -> Platform.Task never () +-- kill proc = +-- Platform.Task +-- (RawScheduler.andThen +-- (\() -> RawScheduler.Value (Ok ())) +-- (RawScheduler.kill proc) +-- ) + + +-- {-| Create a task that sleeps for `time` milliseconds +-- -} +-- sleep : Float -> Platform.Task x () +-- sleep time = +-- Platform.Task +-- (RawScheduler.andThen +-- (\() -> RawScheduler.Value (Ok ())) +-- (RawScheduler.sleep time) +-- ) diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm deleted file mode 100644 index e89723c5..00000000 --- a/src/Platform/Scheduler.elm +++ /dev/null @@ -1,129 +0,0 @@ -module Platform.Scheduler exposing (..) - -{-| - -## Module notes: - -TODO(harry) explain need for this module and how it relates to Platform and - Platform.RawScheduler. - --} - -import Platform -import Platform.RawScheduler as RawScheduler -import Result exposing (Result(..)) -import Basics exposing (..) - - -type alias ProcessId msg - = RawScheduler.ProcessId msg - -type alias DoneCallback err ok = - Platform.Task err ok -> () - - -type alias TryAbortAction = - RawScheduler.TryAbortAction - - -succeed : ok -> Platform.Task never ok -succeed val = - Platform.Task (RawScheduler.Value (Ok val)) - - -fail : err -> Platform.Task err never -fail e = - Platform.Task (RawScheduler.Value (Err e)) - - -binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok -binding callback = - Platform.Task - (RawScheduler.async - (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) - ) - - -andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 -andThen func (Platform.Task task) = - Platform.Task - (RawScheduler.andThen - (\r -> - case r of - Ok val -> - let - (Platform.Task rawTask) = - func val - in - rawTask - - Err e -> - RawScheduler.Value (Err e) - ) - task - ) - - -onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok -onError func (Platform.Task task) = - Platform.Task - (RawScheduler.andThen - (\r -> - case r of - Ok val -> - RawScheduler.Value (Ok val) - - Err e -> - let - (Platform.Task rawTask) = - func e - in - rawTask - ) - task - ) - - -{-| Create a task, if run, will make the process deal with a message. --} -send : ProcessId msg -> msg -> Platform.Task never () -send proc msg = - Platform.Task - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.send proc msg) - ) - - -{-| Create a task that spawns a processes. --} -spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId -spawn (Platform.Task task) = - Platform.Task - (RawScheduler.andThen - (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) - (RawScheduler.spawn task) - ) - - - -{-| Create a task kills a process. --} -kill : ProcessId msg -> Platform.Task never () -kill proc = - Platform.Task - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.kill proc) - ) - - -{-| Create a task that sleeps for `time` milliseconds --} -sleep : Float -> Platform.Task x () -sleep time = - Platform.Task - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.sleep time) - ) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index e36c25ea..0d7c7bef 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -1,5 +1,5 @@ module Platform.Sub exposing - ( Sub(..) + ( Sub , none , batch , map @@ -23,10 +23,11 @@ module Platform.Sub exposing @docs map -} -import Elm.Kernel.Basics +-- import Elm.Kernel.Basics import Basics exposing (..) import List -import Platform.Bag as Bag +import Debug +-- import Platform.Bag as Bag -- SUBSCRIPTIONS @@ -51,14 +52,14 @@ into a real application! type Sub msg -- Constructor name **must** be same as that used in _Platform_leaf() and -- the order of record fields **must** be the same too. - = Data - (List - { home : Bag.EffectManagerName - , value : (Bag.LeafType msg) - , cmdMapper : Never - , subMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB - } - ) + = Sub + -- (List + -- { home : Bag.EffectManagerName + -- , value : (Bag.LeafType msg) + -- , cmdMapper : Never + -- , subMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB + -- } + -- ) @@ -77,9 +78,10 @@ subscriptions. -} batch : List (Sub msg) -> Sub msg batch = - List.map (\(Data sub) -> sub) - >> List.concat - >> Data + Debug.todo "batch" + -- List.map (\(Data sub) -> sub) + -- >> List.concat + -- >> Data @@ -96,17 +98,18 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Sub a -> Sub msg -map fn (Data data) = - data - |> List.map - (\{home, value, cmdMapper, subMapper} -> - { home = home - , value = (fudgeSubMapperType subMapper) fn value - , cmdMapper = cmdMapper - , subMapper = subMapper - } - ) - |> Data +map fn _ = + Debug.todo "map" + -- data + -- |> List.map + -- (\{home, value, cmdMapper, subMapper} -> + -- { home = home + -- , value = (fudgeSubMapperType subMapper) fn value + -- , cmdMapper = cmdMapper + -- , subMapper = subMapper + -- } + -- ) + -- |> Data -- HELPERS -- @@ -116,6 +119,6 @@ type HiddenA = HiddenA Never type HiddenB = HiddenB Never -fudgeSubMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) -fudgeSubMapperType = - Elm.Kernel.Basics.fudgeType +-- fudgeSubMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) +-- fudgeSubMapperType = +-- Elm.Kernel.Basics.fudgeType diff --git a/src/Process.elm b/src/Process.elm index c15a2fb4..8f3e46a8 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -46,8 +46,9 @@ longer. That’s kind of what Elm is all about. import Basics exposing (..) import Platform -import Platform.Scheduler as Scheduler +-- import Platform.Scheduler as Scheduler import Task exposing (Task) +import Debug {-| A light-weight process that runs concurrently. You can use `spawn` to @@ -80,7 +81,7 @@ come in a later release! -} spawn : Task x a -> Task y Id spawn = - Scheduler.spawn + Debug.todo "Scheduler.spawn" {-| Block progress on the current process for the given number of milliseconds. @@ -91,7 +92,7 @@ delay work until later. -} sleep : Float -> Task x () sleep = - Scheduler.sleep + Debug.todo " Scheduler.sleep" {-| Sometimes you `spawn` a process, but later decide it would be a waste to @@ -100,5 +101,5 @@ to bail on whatever task it is running. So if there is an HTTP request in flight, it will also abort the request. -} kill : Id -> Task x () -kill (Platform.ProcessId proc) = - Scheduler.kill proc +kill = + Debug.todo "Scheduler.kill proc" diff --git a/src/Task.elm b/src/Task.elm index 688950e6..3414f598 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -25,12 +25,13 @@ HTTP requests or writing to a database. -} +import Debug import Basics exposing (Never, (|>), (<<)) import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform import Platform.Cmd exposing (Cmd) -import Platform.Scheduler as Scheduler +-- import Platform.Scheduler as Scheduler import Result exposing (Result(..)) @@ -77,7 +78,7 @@ type alias Task x a = -} succeed : a -> Task x a succeed = - Scheduler.succeed + Debug.todo "Scheduler.succeed" {-| A task that fails immediately when run. Like with `succeed`, this can be @@ -91,7 +92,7 @@ used with `andThen` to check on the outcome of another task. -} fail : x -> Task x a fail = - Scheduler.fail + Debug.todo "Scheduler.fail" @@ -206,7 +207,7 @@ First the process sleeps for an hour **and then** it tells us what time it is. -} andThen : (a -> Task x b) -> Task x a -> Task x b andThen = - Scheduler.andThen + Debug.todo "Scheduler.andThen" @@ -226,7 +227,7 @@ callback to recover. -} onError : (x -> Task y a) -> Task x a -> Task y a onError = - Scheduler.onError + Debug.todo "Scheduler.onError" {-| Transform the error value. This can be useful if you need a bunch of error @@ -345,7 +346,7 @@ onSelfMsg _ _ _ = spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x Platform.ProcessId spawnCmd router (Perform task) = - Scheduler.spawn ( + Debug.todo """Scheduler.spawn ( task |> andThen (Platform.sendToApp router) - ) + )""" diff --git a/tests/elm.json b/tests/elm.json index 3c64414c..f0d0a6a8 100644 --- a/tests/elm.json +++ b/tests/elm.json @@ -9,7 +9,7 @@ "elm/html": "1.0.0" }, "indirect": { - "elm/json": "1.1.2", + "elm/json": "1.1.3", "elm/time": "1.0.0", "elm/url": "1.0.0", "elm/virtual-dom": "1.0.2" From b00e34e45d6c3e958e8000ba36e61fa64c39c57c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 8 Dec 2019 22:01:09 +0000 Subject: [PATCH 018/170] time to readd kernel code --- custom-core.sh | 13 +- src/Elm/Kernel/Basics.js | 45 +-- src/Platform.elm | 262 +++++++++--------- src/Platform/{Bag => Bag.elm} | 0 src/Platform/Cmd.elm | 59 ++-- .../{RawScheduler => RawScheduler.elm} | 33 +-- src/Platform/Scheduler | 129 --------- src/Platform/Scheduler.elm | 130 +++++++++ src/Platform/Sub.elm | 59 ++-- src/Task.elm | 14 +- 10 files changed, 348 insertions(+), 396 deletions(-) rename src/Platform/{Bag => Bag.elm} (100%) rename src/Platform/{RawScheduler => RawScheduler.elm} (95%) delete mode 100644 src/Platform/Scheduler create mode 100644 src/Platform/Scheduler.elm diff --git a/custom-core.sh b/custom-core.sh index 9b63b49c..023d4b78 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -12,22 +12,23 @@ printf "Sucess if ends with DONE: " ELM="${ELM:-elm}" ELM_VERSION="$($ELM --version)" -CORE_GIT_DIR=$(realpath .) - -echo CORE_GIT_DIR $CORE_GIT_DIR +CORE_GIT_DIR=$(realpath $1) rm -rf "$ELM_HOME/$ELM_VERSION/packages/elm/core/" cd $1 -if [[ ! -d elm-minimal-master ]]; then +if [[ ! -d elm-minimal ]]; then git clone https://github.com/harrysarson/elm-minimal > /dev/null fi -cd elm-minimal-master +cd elm-minimal +git reset master --hard > /dev/null rm -rf elm-stuff -echo $(pwd) + + $ELM make src/Main.elm --output /dev/null > /dev/null || true; +cd - > /dev/null CORE_VERSION="$(ls $ELM_HOME/$ELM_VERSION/packages/elm/core/)" diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 049291f9..b8c33e63 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -4,35 +4,10 @@ import Elm.Kernel.Debug exposing (crash) */ - // MATH -var _Basics_add = F2(function(a, b) { return a + b; }); -var _Basics_sub = F2(function(a, b) { return a - b; }); -var _Basics_mul = F2(function(a, b) { return a * b; }); -var _Basics_fdiv = F2(function(a, b) { return a / b; }); -var _Basics_idiv = F2(function(a, b) { return (a / b) | 0; }); var _Basics_pow = F2(Math.pow); -var _Basics_remainderBy = F2(function(b, a) { return a % b; }); - -// https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf -var _Basics_modBy = F2(function(modulus, x) -{ - var answer = x % modulus; - return modulus === 0 - ? __Debug_crash(11) - : - ((answer > 0 && modulus < 0) || (answer < 0 && modulus > 0)) - ? answer + modulus - : answer; -}); - - -// TRIGONOMETRY - -var _Basics_pi = Math.PI; -var _Basics_e = Math.E; var _Basics_cos = Math.cos; var _Basics_sin = Math.sin; var _Basics_tan = Math.tan; @@ -42,23 +17,17 @@ var _Basics_atan = Math.atan; var _Basics_atan2 = F2(Math.atan2); -// MORE MATH - -function _Basics_toFloat(x) { return x; } -function _Basics_truncate(n) { return n | 0; } -function _Basics_isInfinite(n) { return n === Infinity || n === -Infinity; } - var _Basics_ceiling = Math.ceil; var _Basics_floor = Math.floor; var _Basics_round = Math.round; var _Basics_sqrt = Math.sqrt; var _Basics_log = Math.log; -var _Basics_isNaN = isNaN; +var _Basics_modBy0 = function() +{ + __Debug_crash(11) +}; -// BOOLEANS - -function _Basics_not(bool) { return !bool; } -var _Basics_and = F2(function(a, b) { return a && b; }); -var _Basics_or = F2(function(a, b) { return a || b; }); -var _Basics_xor = F2(function(a, b) { return a !== b; }); +var _Basics_fudgeType = function(x) { + return x; +}; diff --git a/src/Platform.elm b/src/Platform.elm index 1c39d76c..4d97c987 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -30,37 +30,32 @@ curious? Public discussions of your explorations should be framed accordingly. I have called these `OtherManagers` but what do they do and how shouuld they be named? -} -import Basics exposing (Never) -import Elm.Kernel.Platform -import Elm.Kernel.Scheduler -import Platform.Cmd exposing (Cmd) -import Platform.Sub exposing (Sub) - --- import Basics exposing (..) --- import List exposing ((::)) --- import Maybe exposing (Maybe(..)) --- import Result exposing (Result(..)) --- import String exposing (String) --- import Char exposing (Char) --- import Tuple + +import Basics exposing (..) +import List exposing ((::)) +import Maybe exposing (Maybe(..)) +import Result exposing (Result(..)) +import String exposing (String) +import Char exposing (Char) +import Tuple import Debug --- import Platform.Cmd as Cmd exposing ( Cmd ) --- import Platform.Sub as Sub exposing ( Sub ) +import Platform.Cmd as Cmd exposing ( Cmd ) +import Platform.Sub as Sub exposing ( Sub ) --- import Elm.Kernel.Basics --- import Elm.Kernel.Debug --- import Elm.Kernel.Platform --- import Platform.Bag as Bag --- -- import Json.Decode exposing (Decoder) --- -- import Json.Encode as Encode --- import Dict exposing (Dict) --- import Platform.RawScheduler as RawScheduler +import Elm.Kernel.Basics +import Elm.Kernel.Debug +import Elm.Kernel.Platform +import Platform.Bag as Bag +-- import Json.Decode exposing (Decoder) +-- import Json.Encode as Encode +import Dict exposing (Dict) +import Platform.RawScheduler as RawScheduler --- type Decoder flags = Decoder (Decoder flags) --- type EncodeValue = EncodeValue EncodeValue +type Decoder flags = Decoder (Decoder flags) +type EncodeValue = EncodeValue EncodeValue -- PROGRAMS @@ -70,16 +65,16 @@ show anything on screen? Etc. -} type Program flags model msg = Program - -- ((Decoder flags) -> - -- DebugMetadata -> - -- RawJsObject { args: Maybe (RawJsObject flags) } -> - -- RawJsObject - -- { ports : RawJsObject - -- { outgoingPortName: OutgoingPort - -- , incomingPortName: IncomingPort - -- } - -- } - -- ) + ((Decoder flags) -> + DebugMetadata -> + RawJsObject { args: Maybe (RawJsObject flags) } -> + RawJsObject + { ports : RawJsObject + { outgoingPortName: OutgoingPort + , incomingPortName: IncomingPort + } + } + ) {-| Create a [headless][] program with no user interface. @@ -107,21 +102,23 @@ worker , subscriptions : model -> Sub msg } -> Program flags model msg -worker = - Debug.todo "worker" - -- Program - -- (\flagsDecoder _ args -> - -- initialize - -- flagsDecoder - -- args - -- impl - -- { stepperBuilder = \ _ _ -> (\ _ _ -> ()) - -- , setupOutgoingPort = setupOutgoingPort - -- , setupIncomingPort = setupIncomingPort - -- , setupEffects = hiddenSetupEffects - -- , dispatchEffects = dispatchEffects - -- } - -- ) +worker impl = + makeProgramCallable + (Program + (\flagsDecoder _ args -> + initialize + flagsDecoder + args + impl + { stepperBuilder = \ _ _ -> (\ _ _ -> ()) + , setupOutgoingPort = Debug.todo "setupOutgoingPort" + , setupIncomingPort = Debug.todo "setupIncomingPort" + , setupEffects = Debug.todo "hiddenSetupEffects" + , dispatchEffects = Debug.todo "dispatchEffects" + } + ) + ) + @@ -134,7 +131,7 @@ primitive. -} type Task err ok = Task - -- (RawScheduler.Task (Result err ok)) + (RawScheduler.Task (Result err ok)) {-| Head over to the documentation for the [`Process`](Process) module for @@ -143,7 +140,7 @@ primitive. -} type ProcessId = ProcessId - -- (RawScheduler.ProcessId Never) + (RawScheduler.ProcessId Never) @@ -435,122 +432,127 @@ sendToSelf (Router) msg = -- RawScheduler.rawSetReceiver selfProcess receiver --- type alias SendToApp msg = --- msg -> UpdateMetadata -> () +type alias SendToApp msg = + msg -> UpdateMetadata -> () --- type alias StepperBuilder model msg = --- SendToApp msg -> model -> (SendToApp msg) +type alias StepperBuilder model msg = + SendToApp msg -> model -> (SendToApp msg) --- type alias DebugMetadata = EncodeValue +type alias DebugMetadata = EncodeValue --- {-| AsyncUpdate is default I think +{-| AsyncUpdate is default I think --- TODO(harry) understand this by reading source of VirtualDom --- -} --- type UpdateMetadata --- = SyncUpdate --- | AsyncUpdate +TODO(harry) understand this by reading source of VirtualDom +-} +type UpdateMetadata + = SyncUpdate + | AsyncUpdate --- type OtherManagers appMsg = --- OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) +type OtherManagers appMsg = + OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) --- type ReceivedData appMsg selfMsg --- = Self selfMsg --- | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) +type ReceivedData appMsg selfMsg + = Self selfMsg + | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) --- type EffectManager state appMsg selfMsg --- = EffectManager --- { onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state --- , init : Task Never state --- , onEffects: Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state --- , cmdMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB --- , subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB --- , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) --- } +type EffectManager state appMsg selfMsg + = EffectManager + { onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state + , init : Task Never state + , onEffects: Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state + , cmdMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB + , subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB + , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + } --- type OutgoingPort = --- OutgoingPort --- { subscribe: (EncodeValue -> ()) --- , unsubscribe: (EncodeValue -> ()) --- } +type OutgoingPort = + OutgoingPort + { subscribe: (EncodeValue -> ()) + , unsubscribe: (EncodeValue -> ()) + } --- type IncomingPort = --- IncomingPort --- { send: (EncodeValue -> ()) --- } +type IncomingPort = + IncomingPort + { send: (EncodeValue -> ()) + } --- type HiddenTypeA --- = HiddenTypeA Never +type HiddenTypeA + = HiddenTypeA Never --- type HiddenTypeB --- = HiddenTypeB Never +type HiddenTypeB + = HiddenTypeB Never --- type HiddenMyCmd msg = HiddenMyCmd Never +type HiddenMyCmd msg = HiddenMyCmd Never --- type HiddenMySub msg = HiddenMySub Never +type HiddenMySub msg = HiddenMySub Never --- type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg +type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg --- type HiddenState = HiddenState HiddenState +type HiddenState = HiddenState HiddenState --- type RawJsObject record --- = JsRecord (RawJsObject record) --- | JsAny +type RawJsObject record + = JsRecord (RawJsObject record) + | JsAny --- type alias Impl flags model msg = --- { init : flags -> ( model, Cmd msg ) --- , update : msg -> model -> ( model, Cmd msg ) --- , subscriptions : model -> Sub msg --- } +type alias Impl flags model msg = + { init : flags -> ( model, Cmd msg ) + , update : msg -> model -> ( model, Cmd msg ) + , subscriptions : model -> Sub msg + } --- type alias SetupEffects state appMsg selfMsg = --- SendToApp appMsg --- -> Task Never state --- -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) --- -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) --- -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB) --- -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB) --- -> EffectManager state appMsg selfMsg +type alias SetupEffects state appMsg selfMsg = + SendToApp appMsg + -> Task Never state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) + -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) + -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB) + -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB) + -> EffectManager state appMsg selfMsg --- type alias InitFunctions model appMsg = --- { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) --- , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never --- , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) --- , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg --- , dispatchEffects : OtherManagers appMsg -> Cmd appMsg -> Sub appMsg -> () --- } +type alias InitFunctions model appMsg = + { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) + , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never + , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) + , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg + , dispatchEffects : OtherManagers appMsg -> Cmd appMsg -> Sub appMsg -> () + } -- -- kernel -- --- initialize : --- Decoder flags -> --- RawJsObject { args: Maybe (RawJsObject flags) } -> --- Impl flags model msg -> --- InitFunctions model msg -> --- RawJsObject --- { ports : RawJsObject --- { outgoingPortName: OutgoingPort --- , incomingPortName: IncomingPort --- } --- } --- initialize = --- Elm.Kernel.Platform.initialize +initialize : + Decoder flags -> + RawJsObject { args: Maybe (RawJsObject flags) } -> + Impl flags model msg -> + InitFunctions model msg -> + RawJsObject + { ports : RawJsObject + { outgoingPortName: OutgoingPort + , incomingPortName: IncomingPort + } + } +initialize = + Elm.Kernel.Platform.initialize + + +makeProgramCallable : Program flags model msg -> Program flags model msg +makeProgramCallable (Program program) = + Elm.Kernel.Basics.fudgeType program -- effectManagerNameToString : Bag.EffectManagerName -> String diff --git a/src/Platform/Bag b/src/Platform/Bag.elm similarity index 100% rename from src/Platform/Bag rename to src/Platform/Bag.elm diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 29745cd4..23db2bbe 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -1,5 +1,5 @@ module Platform.Cmd exposing - ( Cmd + ( Cmd(..) , none , batch , map @@ -24,11 +24,10 @@ module Platform.Cmd exposing -} --- import Elm.Kernel.Basics +import Elm.Kernel.Basics import Basics exposing (..) import List -import Debug --- import Platform.Bag as Bag +import Platform.Bag as Bag @@ -51,14 +50,14 @@ fit into a real application! type Cmd msg -- Constructor name **must** be same as that used in _Platform_leaf() and -- the order of record fields **must** be the same too. - = Cmd - -- (List - -- { home : Bag.EffectManagerName - -- , value : (Bag.LeafType msg) - -- , cmdMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB - -- , subMapper : Never - -- } - -- ) + = Data + (List + { home : Bag.EffectManagerName + , value : (Bag.LeafType msg) + , cmdMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB + , subMapper : Never + } + ) {-| Tell the runtime that there are no commands. @@ -78,10 +77,9 @@ all do the same thing. -} batch : List (Cmd msg) -> Cmd msg batch = - Debug.todo "batch" - -- List.map (\(Data cmd) -> cmd) - -- >> List.concat - -- >> Data + List.map (\(Data cmd) -> cmd) + >> List.concat + >> Data -- FANCY STUFF @@ -96,18 +94,17 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Cmd a -> Cmd msg -map fn _ = - Debug.todo "map" - -- data - -- |> List.map - -- (\{home, value, cmdMapper, subMapper} -> - -- { home = home - -- , value = (fudgeCmdMapperType cmdMapper) fn value - -- , cmdMapper = cmdMapper - -- , subMapper = subMapper - -- } - -- ) - -- |> Data +map fn (Data data) = + data + |> List.map + (\{home, value, cmdMapper, subMapper} -> + { home = home + , value = (fudgeCmdMapperType cmdMapper) fn value + , cmdMapper = cmdMapper + , subMapper = subMapper + } + ) + |> Data -- HELPERS -- @@ -117,6 +114,6 @@ type HiddenA = HiddenA Never type HiddenB = HiddenB Never --- fudgeCmdMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) --- fudgeCmdMapperType = --- Elm.Kernel.Basics.fudgeType +fudgeCmdMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) +fudgeCmdMapperType = + Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/RawScheduler b/src/Platform/RawScheduler.elm similarity index 95% rename from src/Platform/RawScheduler rename to src/Platform/RawScheduler.elm index 1b9d552a..40608cfd 100644 --- a/src/Platform/RawScheduler +++ b/src/Platform/RawScheduler.elm @@ -115,7 +115,7 @@ rawSpawn task = enqueue (registerNewProcess (ProcessId - { id = Elm.Kernel.Sceduler.getGuid() + { id = Elm.Kernel.Scheduler.getGuid() } ) (ProcessState @@ -179,14 +179,17 @@ send processId msg = -} spawn : Task a -> Task (ProcessId never) spawn task = - async - (\doneCallback -> + let + thunk : DoneCallback (ProcessId never) -> TryAbortAction + thunk doneCallback = let _ = doneCallback (Value (rawSpawn task)) in (\() -> ()) - ) + in + async + thunk {-| Create a task that sleeps for `time` milliseconds -} @@ -248,26 +251,7 @@ enqueue id = -- Helper functions -- - --- {-| NON PURE! --- -} --- rawStepper : Process -> Process --- rawStepper (Process process) = --- let --- (doEnqueue, newProcess) = --- stepper process - --- _ = --- if doEnqueue then --- enqueue newProcess --- else --- newProcess --- in --- newProcess - - - -{-| NON PURE! +{-| NON PURE! (calls enqueue) This function **must** return a process with the **same ID** as the process it is passed as an argument @@ -381,6 +365,7 @@ enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg enqueueWithStepper = Elm.Kernel.Scheduler.enqueue + delay : Float -> Task val -> DoneCallback val -> TryAbortAction delay = Elm.Kernel.Scheduler.delay diff --git a/src/Platform/Scheduler b/src/Platform/Scheduler deleted file mode 100644 index 5aa78c64..00000000 --- a/src/Platform/Scheduler +++ /dev/null @@ -1,129 +0,0 @@ -module Platform.Scheduler exposing (..) - -{-| - -## Module notes: - -TODO(harry) explain need for this module and how it relates to Platform and - Platform.RawScheduler. - --} - -import Platform -import Platform.RawScheduler as RawScheduler -import Result exposing (Result(..)) -import Basics exposing (..) - - -type alias ProcessId msg - = RawScheduler.ProcessId msg - --- type alias DoneCallback err ok = --- Platform.Task err ok -> () - - --- type alias TryAbortAction = --- RawScheduler.TryAbortAction - - --- succeed : ok -> Platform.Task never ok --- succeed val = --- Platform.Task (RawScheduler.Value (Ok val)) - - --- fail : err -> Platform.Task err never --- fail e = --- Platform.Task (RawScheduler.Value (Err e)) - - --- binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok --- binding callback = --- Platform.Task --- (RawScheduler.async --- (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) --- ) - - --- andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 --- andThen func (Platform.Task task) = --- Platform.Task --- (RawScheduler.andThen --- (\r -> --- case r of --- Ok val -> --- let --- (Platform.Task rawTask) = --- func val --- in --- rawTask - --- Err e -> --- RawScheduler.Value (Err e) --- ) --- task --- ) - - --- onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok --- onError func (Platform.Task task) = --- Platform.Task --- (RawScheduler.andThen --- (\r -> --- case r of --- Ok val -> --- RawScheduler.Value (Ok val) - --- Err e -> --- let --- (Platform.Task rawTask) = --- func e --- in --- rawTask --- ) --- task --- ) - - --- {-| Create a task, if run, will make the process deal with a message. --- -} --- send : ProcessId msg -> msg -> Platform.Task never () --- send proc msg = --- Platform.Task --- (RawScheduler.andThen --- (\() -> RawScheduler.Value (Ok ())) --- (RawScheduler.send proc msg) --- ) - - --- {-| Create a task that spawns a processes. --- -} --- spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId --- spawn (Platform.Task task) = --- Platform.Task --- (RawScheduler.andThen --- (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) --- (RawScheduler.spawn task) --- ) - - - --- {-| Create a task kills a process. --- -} --- kill : ProcessId msg -> Platform.Task never () --- kill proc = --- Platform.Task --- (RawScheduler.andThen --- (\() -> RawScheduler.Value (Ok ())) --- (RawScheduler.kill proc) --- ) - - --- {-| Create a task that sleeps for `time` milliseconds --- -} --- sleep : Float -> Platform.Task x () --- sleep time = --- Platform.Task --- (RawScheduler.andThen --- (\() -> RawScheduler.Value (Ok ())) --- (RawScheduler.sleep time) --- ) diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm new file mode 100644 index 00000000..19c7e32a --- /dev/null +++ b/src/Platform/Scheduler.elm @@ -0,0 +1,130 @@ +module Platform.Scheduler exposing (..) + +{-| + +## Module notes: + +TODO(harry) explain need for this module and how it relates to Platform and + Platform.RawScheduler. + +-} + +import Platform +import Platform.RawScheduler as RawScheduler +import Result exposing (Result(..)) +import Basics exposing (..) +import Debug + + +type alias ProcessId msg + = RawScheduler.ProcessId msg + +type alias DoneCallback err ok = + Platform.Task err ok -> () + + +type alias TryAbortAction = + RawScheduler.TryAbortAction + + +succeed : ok -> Platform.Task never ok +succeed val = + Platform.Task (RawScheduler.Value (Ok val)) + + +fail : err -> Platform.Task err never +fail e = + Platform.Task (RawScheduler.Value (Err e)) + + +binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok +binding callback = + Platform.Task + (RawScheduler.async + (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) + ) + + +andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 +andThen func (Platform.Task task) = + Platform.Task + (RawScheduler.andThen + (\r -> + case r of + Ok val -> + let + (Platform.Task rawTask) = + func val + in + rawTask + + Err e -> + RawScheduler.Value (Err e) + ) + task + ) + + +onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok +onError func (Platform.Task task) = + Platform.Task + (RawScheduler.andThen + (\r -> + case r of + Ok val -> + RawScheduler.Value (Ok val) + + Err e -> + let + (Platform.Task rawTask) = + func e + in + rawTask + ) + task + ) + + +{-| Create a task, if run, will make the process deal with a message. +-} +send : ProcessId msg -> msg -> Platform.Task never () +send proc msg = + Platform.Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.send proc msg) + ) + + +{-| Create a task that spawns a processes. +-} +spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId +spawn (Platform.Task task) = + Platform.Task + (RawScheduler.andThen + (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) + (RawScheduler.spawn task) + ) + + + +{-| Create a task kills a process. +-} +kill : ProcessId msg -> Platform.Task never () +kill proc = + Platform.Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.kill proc) + ) + + +{-| Create a task that sleeps for `time` milliseconds +-} +sleep : Float -> Platform.Task x () +sleep time = + Platform.Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.sleep time) + ) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 0d7c7bef..e36c25ea 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -1,5 +1,5 @@ module Platform.Sub exposing - ( Sub + ( Sub(..) , none , batch , map @@ -23,11 +23,10 @@ module Platform.Sub exposing @docs map -} --- import Elm.Kernel.Basics +import Elm.Kernel.Basics import Basics exposing (..) import List -import Debug --- import Platform.Bag as Bag +import Platform.Bag as Bag -- SUBSCRIPTIONS @@ -52,14 +51,14 @@ into a real application! type Sub msg -- Constructor name **must** be same as that used in _Platform_leaf() and -- the order of record fields **must** be the same too. - = Sub - -- (List - -- { home : Bag.EffectManagerName - -- , value : (Bag.LeafType msg) - -- , cmdMapper : Never - -- , subMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB - -- } - -- ) + = Data + (List + { home : Bag.EffectManagerName + , value : (Bag.LeafType msg) + , cmdMapper : Never + , subMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB + } + ) @@ -78,10 +77,9 @@ subscriptions. -} batch : List (Sub msg) -> Sub msg batch = - Debug.todo "batch" - -- List.map (\(Data sub) -> sub) - -- >> List.concat - -- >> Data + List.map (\(Data sub) -> sub) + >> List.concat + >> Data @@ -98,18 +96,17 @@ section on [structure][] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html -} map : (a -> msg) -> Sub a -> Sub msg -map fn _ = - Debug.todo "map" - -- data - -- |> List.map - -- (\{home, value, cmdMapper, subMapper} -> - -- { home = home - -- , value = (fudgeSubMapperType subMapper) fn value - -- , cmdMapper = cmdMapper - -- , subMapper = subMapper - -- } - -- ) - -- |> Data +map fn (Data data) = + data + |> List.map + (\{home, value, cmdMapper, subMapper} -> + { home = home + , value = (fudgeSubMapperType subMapper) fn value + , cmdMapper = cmdMapper + , subMapper = subMapper + } + ) + |> Data -- HELPERS -- @@ -119,6 +116,6 @@ type HiddenA = HiddenA Never type HiddenB = HiddenB Never --- fudgeSubMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) --- fudgeSubMapperType = --- Elm.Kernel.Basics.fudgeType +fudgeSubMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) +fudgeSubMapperType = + Elm.Kernel.Basics.fudgeType diff --git a/src/Task.elm b/src/Task.elm index 3414f598..6eb124ae 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -31,7 +31,7 @@ import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform import Platform.Cmd exposing (Cmd) --- import Platform.Scheduler as Scheduler +import Platform.Scheduler as Scheduler import Result exposing (Result(..)) @@ -78,7 +78,7 @@ type alias Task x a = -} succeed : a -> Task x a succeed = - Debug.todo "Scheduler.succeed" + Scheduler.succeed {-| A task that fails immediately when run. Like with `succeed`, this can be @@ -92,7 +92,7 @@ used with `andThen` to check on the outcome of another task. -} fail : x -> Task x a fail = - Debug.todo "Scheduler.fail" + Scheduler.fail @@ -207,7 +207,7 @@ First the process sleeps for an hour **and then** it tells us what time it is. -} andThen : (a -> Task x b) -> Task x a -> Task x b andThen = - Debug.todo "Scheduler.andThen" + Scheduler.andThen @@ -227,7 +227,7 @@ callback to recover. -} onError : (x -> Task y a) -> Task x a -> Task y a onError = - Debug.todo "Scheduler.onError" + Scheduler.onError {-| Transform the error value. This can be useful if you need a bunch of error @@ -346,7 +346,7 @@ onSelfMsg _ _ _ = spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x Platform.ProcessId spawnCmd router (Perform task) = - Debug.todo """Scheduler.spawn ( + Scheduler.spawn ( task |> andThen (Platform.sendToApp router) - )""" + ) From a1c3e17cf4428150077b0fbb64a885a75de5e23c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 8 Dec 2019 22:42:50 +0000 Subject: [PATCH 019/170] pulled in new kernel code --- elm-minimal | 1 + src/Elm/Kernel/Bitwise.js | 39 --- src/Elm/Kernel/Platform.js | 507 ++++++++++++------------------- src/Elm/Kernel/Process.js | 18 -- src/Elm/Kernel/Process.server.js | 11 - src/Elm/Kernel/Scheduler.js | 204 ++++--------- src/Platform/RawScheduler.elm | 2 +- 7 files changed, 247 insertions(+), 535 deletions(-) create mode 160000 elm-minimal delete mode 100644 src/Elm/Kernel/Bitwise.js delete mode 100644 src/Elm/Kernel/Process.js delete mode 100644 src/Elm/Kernel/Process.server.js diff --git a/elm-minimal b/elm-minimal new file mode 160000 index 00000000..a6f5b06e --- /dev/null +++ b/elm-minimal @@ -0,0 +1 @@ +Subproject commit a6f5b06e82adf9bd058d5a85dc12e9cbd4d16bab diff --git a/src/Elm/Kernel/Bitwise.js b/src/Elm/Kernel/Bitwise.js deleted file mode 100644 index 612e8c7c..00000000 --- a/src/Elm/Kernel/Bitwise.js +++ /dev/null @@ -1,39 +0,0 @@ -/* - -*/ - - -var _Bitwise_and = F2(function(a, b) -{ - return a & b; -}); - -var _Bitwise_or = F2(function(a, b) -{ - return a | b; -}); - -var _Bitwise_xor = F2(function(a, b) -{ - return a ^ b; -}); - -function _Bitwise_complement(a) -{ - return ~a; -}; - -var _Bitwise_shiftLeftBy = F2(function(offset, a) -{ - return a << offset; -}); - -var _Bitwise_shiftRightBy = F2(function(offset, a) -{ - return a >> offset; -}); - -var _Bitwise_shiftRightZfBy = F2(function(offset, a) -{ - return a >>> offset; -}); diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index c1726550..4546c3f9 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -2,54 +2,70 @@ import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) -import Elm.Kernel.List exposing (Cons, Nil) -import Elm.Kernel.Process exposing (sleep) -import Elm.Kernel.Scheduler exposing (andThen, binding, rawSend, rawSpawn, receive, send, succeed) +import Elm.Kernel.List exposing (Nil) import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) */ +// State +var _Platform_outgoingPorts = {}; +var _Platform_incomingPorts = {}; +var _Platform_effectManagers = {}; +var _Platform_compiledEffectManagers = {}; -// PROGRAMS +// INITIALIZE A PROGRAM -var _Platform_worker = F4(function(impl, flagDecoder, debugMetadata, args) +function _Platform_initialize(flagDecoder, args, impl, functions) { - return _Platform_initialize( - flagDecoder, - args, - impl.__$init, - impl.__$update, - impl.__$subscriptions, - function() { return function() {} } - ); -}); - + // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value + // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a + const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); + if (!__Result_isOk(flagsResult)) { + __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); + } -// INITIALIZE A PROGRAM - + const managers = {}; + const ports = {}; + const initValue = impl.__$init(flagsResult.a); + var model = initValue.a; + const stepper = A2(functions.__$stepperBuilder, sendToApp, model); -function _Platform_initialize(flagDecoder, args, init, update, subscriptions, stepperBuilder) -{ - var result = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); - __Result_isOk(result) || __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); - var managers = {}; - result = init(result.a); - var model = result.a; - var stepper = stepperBuilder(sendToApp, model); - var ports = _Platform_setupEffects(managers, sendToApp); - - function sendToApp(msg, viewMetadata) + for (var key in _Platform_effectManagers) + { + const setup = _Platform_effectManagers[key]; + _Platform_compiledEffectManagers[key] = + setup(functions.__$setupEffects, sendToApp); + managers[key] = setup; + } + for (var key in _Platform_outgoingPorts) { - result = A2(update, msg, model); - stepper(model = result.a, viewMetadata); - _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + const setup = _Platform_outgoingPorts[key]; + _Platform_compiledEffectManagers[key] = + setup(functions.__$setupOutgoingPort, sendToApp); + ports[key] = setup.ports; + managers[key] = setup.manger; } + for (var key in _Platform_incomingPorts) + { + const setup = _Platform_incomingPorts[key]; + _Platform_compiledEffectManagers[key] = + setup(functions.__$setupIncomingPort, sendToApp); + ports[key] = setup.ports; + managers[key] = setup.manger; + } + + const sendToApp = F2((msg, viewMetadata) => { + const updateValue = A2(impl.__$update, msg, model); + model = updateValue.a + A2(stepper, model, viewMetadata); + A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); + }) - _Platform_dispatchEffects(managers, result.b, subscriptions(model)); + A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); return ports ? { ports: ports } : {}; } @@ -76,353 +92,218 @@ function _Platform_registerPreload(url) // EFFECT MANAGERS -var _Platform_effectManagers = {}; - - -function _Platform_setupEffects(managers, sendToApp) -{ - var ports; - - // setup all necessary effect managers - for (var key in _Platform_effectManagers) - { - var manager = _Platform_effectManagers[key]; - - if (manager.__portSetup) - { - ports = ports || {}; - ports[key] = manager.__portSetup(key, sendToApp); - } - - managers[key] = _Platform_instantiateManager(manager, sendToApp); - } - return ports; +function _Platform_getEffectManager(name) { + return _Platform_compiledEffectManagers[name]; } - -function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) -{ - return { - __init: init, - __onEffects: onEffects, - __onSelfMsg: onSelfMsg, - __cmdMap: cmdMap, - __subMap: subMap - }; +function _Platform_effectManagerNameToString(name) { + return name; } -function _Platform_instantiateManager(info, sendToApp) +// Called by compiler generated js when creating event mangers +function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { - var router = { - __sendToApp: sendToApp, - __selfProcess: undefined - }; - - var onEffects = info.__onEffects; - var onSelfMsg = info.__onSelfMsg; - var cmdMap = info.__cmdMap; - var subMap = info.__subMap; - - function loop(state) - { - return A2(__Scheduler_andThen, loop, __Scheduler_receive(function(msg) - { - var value = msg.a; - - if (msg.$ === __2_SELF) - { - return A3(onSelfMsg, router, value, state); + // TODO(harry) confirm this is valid + let fullOnEffects, fullCmdMap, fullSubMap; + if (cmdMap === undefined) { + // Subscription only effect module + fullOnEffects = F4(function(router, cmds, subs, state) { + return A3(onEffects, router, subs, state); + }); + fullCmdMap = F2(function(tagger, _val) { + /**__DEBUG/ + if (procState === undefined) { + console.error(`INTERNAL ERROR: attempt to map Cmd for subscription only effect module!`); } - - return cmdMap && subMap - ? A4(onEffects, router, value.__cmds, value.__subs, state) - : A3(onEffects, router, cmdMap ? value.__cmds : value.__subs, state); - })); + //*/ + }); + fullSubMap = subMap; + } else if (subMap === undefined) { + // Command only effect module + fullOnEffects = F4(function(router, cmds, subs, state) { + return A3(onEffects, router, cmds, state); + }); + fullCmdMap = cmdMap; + fullSubMap = F2(function(tagger, _val) { + /**__DEBUG/ + if (procState === undefined) { + console.error(`INTERNAL ERROR: attempt to map Sub for command only effect module!`); + } + //*/ + }); + } else { + fullOnEffects = onEffects; + fullCmdMap = cmdMap; + fullSubMap = subMap; } - - return router.__selfProcess = __Scheduler_rawSpawn(A2(__Scheduler_andThen, loop, info.__init)); + // Command **and** subscription event manager + return function(setup, sendToApp) { + return A6(setup, sendToApp, init, fullOnEffects, onSelfMsg, fullCmdMap, fullSubMap) + }; } - - -// ROUTING - - -var _Platform_sendToApp = F2(function(router, msg) -{ - return __Scheduler_binding(function(callback) - { - router.__sendToApp(msg); - callback(__Scheduler_succeed(__Utils_Tuple0)); - }); -}); - - -var _Platform_sendToSelf = F2(function(router, msg) -{ - return A2(__Scheduler_send, router.__selfProcess, { - $: __2_SELF, - a: msg - }); -}); - - - // BAGS +/* Called by compiler generated js for event managers for the + * `command` or `subscription` function within an event manager + */ function _Platform_leaf(home) { return function(value) { + /**__DEBUG/ return { - $: __2_LEAF, - __home: home, - __value: value + $: 'Data', + a: { + $: '::', + a: { + a: { + $: __1_EFFECTMANAGERNAME, + a: home + }, + b: { + $: __2_LEAFTYPE, + a: value + }, + c: _Platform_compiledEffectManagers[home].__$cmdMap, + d: _Platform_compiledEffectManagers[home].__$subMap + }, + b: { + $: '[]' + } + } }; - }; -} - - -function _Platform_batch(list) -{ - return { - $: __2_NODE, - __bags: list - }; -} - - -var _Platform_map = F2(function(tagger, bag) -{ - return { - $: __2_MAP, - __func: tagger, - __bag: bag - } -}); - - - -// PIPE BAGS INTO EFFECT MANAGERS - - -function _Platform_dispatchEffects(managers, cmdBag, subBag) -{ - var effectsDict = {}; - _Platform_gatherEffects(true, cmdBag, effectsDict, null); - _Platform_gatherEffects(false, subBag, effectsDict, null); - - for (var home in managers) - { - __Scheduler_rawSend(managers[home], { - $: 'fx', - a: effectsDict[home] || { __cmds: __List_Nil, __subs: __List_Nil } - }); - } -} - + //*/ -function _Platform_gatherEffects(isCmd, bag, effectsDict, taggers) -{ - switch (bag.$) - { - case __2_LEAF: - var home = bag.__home; - var effect = _Platform_toEffect(isCmd, home, taggers, bag.__value); - effectsDict[home] = _Platform_insert(isCmd, effect, effectsDict[home]); - return; - - case __2_NODE: - for (var list = bag.__bags; list.b; list = list.b) // WHILE_CONS - { - _Platform_gatherEffects(isCmd, list.a, effectsDict, taggers); + /**__PROD/ + return { + $: , + a: { + $: 1, + a: { + a: { + $: __1_EFFECTMANAGERNAME, + a: home + }, + b: { + $: __2_LEAFTYPE, + a: value + }, + c: _Platform_compiledEffectManagers[home].__$cmdMap, + d: _Platform_compiledEffectManagers[home].__$subMap + }, + b: { + $: 0 + } } - return; - - case __2_MAP: - _Platform_gatherEffects(isCmd, bag.__bag, effectsDict, { - __tagger: bag.__func, - __rest: taggers - }); - return; - } -} - - -function _Platform_toEffect(isCmd, home, taggers, value) -{ - function applyTaggers(x) - { - for (var temp = taggers; temp; temp = temp.__rest) - { - x = temp.__tagger(x); - } - return x; - } - - var map = isCmd - ? _Platform_effectManagers[home].__cmdMap - : _Platform_effectManagers[home].__subMap; - - return A2(map, applyTaggers, value) -} - - -function _Platform_insert(isCmd, newEffect, effects) -{ - effects = effects || { __cmds: __List_Nil, __subs: __List_Nil }; - - isCmd - ? (effects.__cmds = __List_Cons(newEffect, effects.__cmds)) - : (effects.__subs = __List_Cons(newEffect, effects.__subs)); - - return effects; + }; + //*/ + }; } - // PORTS function _Platform_checkPortName(name) { - if (_Platform_effectManagers[name]) + if (_Platform_compiledEffectManagers[name]) { __Debug_crash(3, name) } } - -// OUTGOING PORTS - - function _Platform_outgoingPort(name, converter) { _Platform_checkPortName(name); - _Platform_effectManagers[name] = { - __cmdMap: _Platform_outgoingPortMap, - __converter: converter, - __portSetup: _Platform_setupOutgoingPort - }; - return _Platform_leaf(name); -} - - -var _Platform_outgoingPortMap = F2(function(tagger, value) { return value; }); - - -function _Platform_setupOutgoingPort(name) -{ - var subs = []; - var converter = _Platform_effectManagers[name].__converter; - - // CREATE MANAGER + _Platform_outgoingPorts[name] = function(setup, sendToApp) { + let subs = []; - var init = __Process_sleep(0); + function subscribe(callback) + { + subs.push(callback); + } - _Platform_effectManagers[name].__init = init; - _Platform_effectManagers[name].__onEffects = F3(function(router, cmdList, state) - { - for ( ; cmdList.b; cmdList = cmdList.b) // WHILE_CONS + function unsubscribe(callback) { - // grab a separate reference to subs in case unsubscribe is called - var currentSubs = subs; - var value = __Json_unwrap(converter(cmdList.a)); - for (var i = 0; i < currentSubs.length; i++) + // copy subs into a new array in case unsubscribe is called within a + // subscribed callback + subs = subs.slice(); + var index = subs.indexOf(callback); + if (index >= 0) { - currentSubs[i](value); + subs.splice(index, 1); } } - return init; - }); - // PUBLIC API + const outgoingPortSend = payload => { + var value = __Json_unwrap(payload); + for (const sub of subs) + { + sub(value); + } + return __Utils_Tuple0; + }; - function subscribe(callback) - { - subs.push(callback); - } - function unsubscribe(callback) - { - // copy subs into a new array in case unsubscribe is called within a - // subscribed callback - subs = subs.slice(); - var index = subs.indexOf(callback); - if (index >= 0) - { - subs.splice(index, 1); + const manager = A3( + setup, + sendToApp, + outgoingPortSend, + { + subscribe: subscribe, + unsubscribe: unsubscribe + }, + ); + + return { + ports: { + subscribe, + unsubscribe, + }, + manager, } } - return { - subscribe: subscribe, - unsubscribe: unsubscribe - }; + return _Platform_leaf(name) } - -// INCOMING PORTS - - function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - _Platform_effectManagers[name] = { - __subMap: _Platform_incomingPortMap, - __converter: converter, - __portSetup: _Platform_setupIncomingPort - }; - return _Platform_leaf(name); -} - - -var _Platform_incomingPortMap = F2(function(tagger, finalTagger) -{ - return function(value) - { - return tagger(finalTagger(value)); - }; -}); + _Platform_incomingPorts[name] = function(setup, sendToApp) { + let subs = __List_Nil; + function updateSubs(subsList) { + subs = subsList; + } -function _Platform_setupIncomingPort(name, sendToApp) -{ - var subs = __List_Nil; - var converter = _Platform_effectManagers[name].__converter; - - // CREATE MANAGER - - var init = __Scheduler_succeed(null); + const setupTuple = A2(setup, sendToApp, updateSubs); - _Platform_effectManagers[name].__init = init; - _Platform_effectManagers[name].__onEffects = F3(function(router, subList, state) - { - subs = subList; - return init; - }); + function send(incomingValue) + { + var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); - // PUBLIC API + __Result_isOk(result) || __Debug_crash(4, name, result.a); - function send(incomingValue) - { - var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); - - __Result_isOk(result) || __Debug_crash(4, name, result.a); + var value = result.a; + A2(setupTuple.b, value, subs); + } - var value = result.a; - for (var temp = subs; temp.b; temp = temp.b) // WHILE_CONS - { - sendToApp(temp.a(value)); + return { + ports: { + send, + }, + manager: setupTuple.a, } } - return { send: send }; + return _Platform_leaf(name) } diff --git a/src/Elm/Kernel/Process.js b/src/Elm/Kernel/Process.js deleted file mode 100644 index 4a750f32..00000000 --- a/src/Elm/Kernel/Process.js +++ /dev/null @@ -1,18 +0,0 @@ -/* - -import Elm.Kernel.Scheduler exposing (binding, succeed) -import Elm.Kernel.Utils exposing (Tuple0) - -*/ - - -function _Process_sleep(time) -{ - return __Scheduler_binding(function(callback) { - var id = setTimeout(function() { - callback(__Scheduler_succeed(__Utils_Tuple0)); - }, time); - - return function() { clearTimeout(id); }; - }); -} diff --git a/src/Elm/Kernel/Process.server.js b/src/Elm/Kernel/Process.server.js deleted file mode 100644 index 9230604a..00000000 --- a/src/Elm/Kernel/Process.server.js +++ /dev/null @@ -1,11 +0,0 @@ -/* - -import Elm.Kernel.Scheduler exposing (binding) - -*/ - - -function _Process_sleep() -{ - return __Scheduler_binding(function() {}); -} diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 37a68be8..99fef696 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -1,195 +1,93 @@ /* -import Elm.Kernel.Utils exposing (Tuple0) +import Platform.Scheduler as NiceScheduler exposing (succeed, binding) */ +// COMPATIBILITY -// TASKS +/* + * We include these to avoid having to change code + * in other `elm/*` packages. + * + * We have to define these as functions rather than + * variables as the implementations of + * elm/core:Platform.Scheduler.* functions may come + * later in the generated javascript file. + */ function _Scheduler_succeed(value) { - return { - $: __1_SUCCEED, - __value: value - }; -} - -function _Scheduler_fail(error) -{ - return { - $: __1_FAIL, - __value: error - }; + return __NiceScheduler_succeed(value); } function _Scheduler_binding(callback) { - return { - $: __1_BINDING, - __callback: callback, - __kill: null - }; + return __NiceScheduler_binding(callback); } -var _Scheduler_andThen = F2(function(callback, task) -{ - return { - $: __1_AND_THEN, - __callback: callback, - __task: task - }; -}); +// SCHEDULER -var _Scheduler_onError = F2(function(callback, task) -{ - return { - $: __1_ON_ERROR, - __callback: callback, - __task: task - }; -}); - -function _Scheduler_receive(callback) -{ - return { - $: __1_RECEIVE, - __callback: callback - }; -} - - -// PROCESSES var _Scheduler_guid = 0; +var _Scheduler_processes = new WeakMap(); -function _Scheduler_rawSpawn(task) -{ - var proc = { - $: __2_PROCESS, - __id: _Scheduler_guid++, - __root: task, - __stack: null, - __mailbox: [] - }; - - _Scheduler_enqueue(proc); - - return proc; +function _Scheduler_getGuid() { + return Object.create({ id: _Scheduler_guid++ }); } -function _Scheduler_spawn(task) -{ - return _Scheduler_binding(function(callback) { - callback(_Scheduler_succeed(_Scheduler_rawSpawn(task))); - }); -} - -function _Scheduler_rawSend(proc, msg) -{ - proc.__mailbox.push(msg); - _Scheduler_enqueue(proc); +function _Scheduler_getProcessState(id) { + const procState = _Scheduler_processes.get(id); + /**__DEBUG/ + if (procState === undefined) { + console.error(`INTERNAL ERROR: Process with id ${id} is not in map!`); + } + //*/ + return procState; } -var _Scheduler_send = F2(function(proc, msg) -{ - return _Scheduler_binding(function(callback) { - _Scheduler_rawSend(proc, msg); - callback(_Scheduler_succeed(__Utils_Tuple0)); - }); +var _Scheduler_updateProcessState = F2((func, id) => { + const procState = _Scheduler_getProcessState.get(id); + _Scheduler_processes.set(id, func(procState)); + return procState; }); -function _Scheduler_kill(proc) -{ - return _Scheduler_binding(function(callback) { - var task = proc.__root; - if (task.$ === __1_BINDING && task.__kill) - { - task.__kill(); - } - - proc.__root = null; - - callback(_Scheduler_succeed(__Utils_Tuple0)); - }); -} - - -/* STEP PROCESSES - -type alias Process = - { $ : tag - , id : unique_id - , root : Task - , stack : null | { $: SUCCEED | FAIL, a: callback, b: stack } - , mailbox : [msg] - } - -*/ +var _Scheduler_registerNewProcess = F2((procId, procState) => { + /**__DEBUG/ + if (_Scheduler_processes.has(procId)) { + console.error(`INTERNAL ERROR: Process with id ${id} is already in map!`); + } + //*/ + _Scheduler_processes.set(procId, procState); + return procId; +}); var _Scheduler_working = false; var _Scheduler_queue = []; - -function _Scheduler_enqueue(proc) +var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) { - _Scheduler_queue.push(proc); + _Scheduler_queue.push(procId); if (_Scheduler_working) { return; } _Scheduler_working = true; - while (proc = _Scheduler_queue.shift()) + while (procId = _Scheduler_queue.shift()) { - _Scheduler_step(proc); + stepper(procId); } _Scheduler_working = false; -} + return procId; +}); -function _Scheduler_step(proc) +var _Scheduler_delay = F3(function (time, value, callback) { - while (proc.__root) - { - var rootTag = proc.__root.$; - if (rootTag === __1_SUCCEED || rootTag === __1_FAIL) - { - while (proc.__stack && proc.__stack.$ !== rootTag) - { - proc.__stack = proc.__stack.__rest; - } - if (!proc.__stack) - { - return; - } - proc.__root = proc.__stack.__callback(proc.__root.__value); - proc.__stack = proc.__stack.__rest; - } - else if (rootTag === __1_BINDING) - { - proc.__root.__kill = proc.__root.__callback(function(newRoot) { - proc.__root = newRoot; - _Scheduler_enqueue(proc); - }); - return; - } - else if (rootTag === __1_RECEIVE) - { - if (proc.__mailbox.length === 0) - { - return; - } - proc.__root = proc.__root.__callback(proc.__mailbox.shift()); - } - else // if (rootTag === __1_AND_THEN || rootTag === __1_ON_ERROR) - { - proc.__stack = { - $: rootTag === __1_AND_THEN ? __1_SUCCEED : __1_FAIL, - __callback: proc.__root.__callback, - __rest: proc.__stack - }; - proc.__root = proc.__root.__task; - } - } -} + var id = setTimeout(function() { + callback(value); + }, time); + + return function(x) { clearTimeout(id); return x; }; +}); diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 40608cfd..03c1cab7 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -363,7 +363,7 @@ registerNewProcess = enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg enqueueWithStepper = - Elm.Kernel.Scheduler.enqueue + Elm.Kernel.Scheduler.enqueueWithStepper delay : Float -> Task val -> DoneCallback val -> TryAbortAction From f41180b7ce1c06b168f7c932ae139c2f5411db8d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 9 Dec 2019 18:42:37 +0000 Subject: [PATCH 020/170] crash better --- src/Elm/Kernel/Debug.js | 77 ++++++++++++++++++++++++++----------- src/Elm/Kernel/Platform.js | 32 ++++++++------- src/Elm/Kernel/Scheduler.js | 8 ++-- src/Platform.elm | 4 +- 4 files changed, 78 insertions(+), 43 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 07e3ba96..963d5abc 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -247,49 +247,80 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) throw new Error('Browser.application programs cannot handle URLs like this:\n\n ' + document.location.href + '\n\nWhat is the root? The root of your file system? Try looking at this program with `elm reactor` or some other server.'); case 2: - var jsonErrorString = fact1; - throw new Error('Problem with the flags given to your Elm program on initialization.\n\n' + jsonErrorString); + { + var jsonErrorString = fact1; + throw new Error('Problem with the flags given to your Elm program on initialization.\n\n' + jsonErrorString); + } case 3: - var portName = fact1; - throw new Error('There can only be one port named `' + portName + '`, but your program has multiple.'); + { + var portName = fact1; + throw new Error('There can only be one port named `' + portName + '`, but your program has multiple.'); + } case 4: - var portName = fact1; - var problem = fact2; - throw new Error('Trying to send an unexpected type of value through port `' + portName + '`:\n' + problem); + { + var portName = fact1; + var problem = fact2; + throw new Error('Trying to send an unexpected type of value through port `' + portName + '`:\n' + problem); + } case 5: throw new Error('Trying to use `(==)` on functions.\nThere is no way to know if functions are "the same" in the Elm sense.\nRead more about this at https://package.elm-lang.org/packages/elm/core/latest/Basics#== which describes why it is this way and what the better version will look like.'); case 6: - var moduleName = fact1; - throw new Error('Your page is loading multiple Elm scripts with a module named ' + moduleName + '. Maybe a duplicate script is getting loaded accidentally? If not, rename one of them so I know which is which!'); + { + var moduleName = fact1; + throw new Error('Your page is loading multiple Elm scripts with a module named ' + moduleName + '. Maybe a duplicate script is getting loaded accidentally? If not, rename one of them so I know which is which!'); + } case 8: - var moduleName = fact1; - var region = fact2; - var message = fact3; - throw new Error('TODO in module `' + moduleName + '` ' + _Debug_regionToString(region) + '\n\n' + message); + { + var moduleName = fact1; + var region = fact2; + var message = fact3; + throw new Error('TODO in module `' + moduleName + '` ' + _Debug_regionToString(region) + '\n\n' + message); + } case 9: - var moduleName = fact1; - var region = fact2; - var value = fact3; - var message = fact4; - throw new Error( - 'TODO in module `' + moduleName + '` from the `case` expression ' - + _Debug_regionToString(region) + '\n\nIt received the following value:\n\n ' - + _Debug_toString(value).replace('\n', '\n ') - + '\n\nBut the branch that handles it says:\n\n ' + message.replace('\n', '\n ') - ); + { + var moduleName = fact1; + var region = fact2; + var value = fact3; + var message = fact4; + throw new Error( + 'TODO in module `' + moduleName + '` from the `case` expression ' + + _Debug_regionToString(region) + '\n\nIt received the following value:\n\n ' + + _Debug_toString(value).replace('\n', '\n ') + + '\n\nBut the branch that handles it says:\n\n ' + message.replace('\n', '\n ') + ); + } case 10: throw new Error('Bug in https://github.com/elm/virtual-dom/issues'); case 11: throw new Error('Cannot perform mod 0. Division by zero error.'); + + case 12: + { + switch (fact1) { + case 'subMap': + throw new Error('Bug in elm runtime: attempting to subMap command only effect module.'); + + case 'cmdMap': + throw new Error('Bug in elm runtime: attempting to cmdMap subscription only effect module.'); + + case 'procIdAlreadyRegistered': + throw new Error(`Bug in elm runtime: state for process ${fact1} is already registered!`); + + case 'procIdNotRegistered': + throw new Error(`Bug in elm runtime: state for process ${fact1} has not registered!`); + } + throw new Error(`Unknown bug in elm runtime id: ${identifier}!`); + } } + throw new Error(`Unknown error id: ${identifier}!`); } function _Debug_regionToString(region) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 4546c3f9..c588b1c5 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -101,6 +101,22 @@ function _Platform_effectManagerNameToString(name) { return name; } +const _Platform_subOnlyCmdMap = F2(function(_1, _2) { + /**__DEBUG/ + if (procState === undefined) { + __Debug_crash(12, 'cmdMap'); + } + //*/ +}); + +const _Platform_cmdOnlySubMap = F2(function(_1, _2) { + /**__DEBUG/ + if (procState === undefined) { + __Debug_crash(12, 'subMap'); + } + //*/ +}); + // Called by compiler generated js when creating event mangers function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) @@ -112,13 +128,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) fullOnEffects = F4(function(router, cmds, subs, state) { return A3(onEffects, router, subs, state); }); - fullCmdMap = F2(function(tagger, _val) { - /**__DEBUG/ - if (procState === undefined) { - console.error(`INTERNAL ERROR: attempt to map Cmd for subscription only effect module!`); - } - //*/ - }); + fullCmdMap = _Platform_subOnlyCmdMap; fullSubMap = subMap; } else if (subMap === undefined) { // Command only effect module @@ -126,13 +136,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) return A3(onEffects, router, cmds, state); }); fullCmdMap = cmdMap; - fullSubMap = F2(function(tagger, _val) { - /**__DEBUG/ - if (procState === undefined) { - console.error(`INTERNAL ERROR: attempt to map Sub for command only effect module!`); - } - //*/ - }); + fullSubMap = _Platform_cmdOnlySubMap; } else { fullOnEffects = onEffects; fullCmdMap = cmdMap; diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 99fef696..a4cbf45e 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -1,7 +1,7 @@ /* import Platform.Scheduler as NiceScheduler exposing (succeed, binding) - +import Elm.Kernel.Debug exposing (crash) */ // COMPATIBILITY @@ -40,7 +40,7 @@ function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { - console.error(`INTERNAL ERROR: Process with id ${id} is not in map!`); + __Debug_crash(12, 'procIdNotRegistered'); } //*/ return procState; @@ -54,8 +54,8 @@ var _Scheduler_updateProcessState = F2((func, id) => { var _Scheduler_registerNewProcess = F2((procId, procState) => { /**__DEBUG/ - if (_Scheduler_processes.has(procId)) { - console.error(`INTERNAL ERROR: Process with id ${id} is already in map!`); + if (procState === undefined) { + __Debug_crash(12, 'procIdAlreadyRegistered'); } //*/ _Scheduler_processes.set(procId, procState); diff --git a/src/Platform.elm b/src/Platform.elm index 4d97c987..65c587ce 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -237,7 +237,7 @@ sendToSelf (Router) msg = -- , init = init -- , onEffects = onEffects -- , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) --- , subMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here +-- , subMap = (\ _ _ -> Elm.Kernel.Platform.cmdOnlySubMap) -- , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg -- } @@ -287,7 +287,7 @@ sendToSelf (Router) msg = -- { onSelfMsg = onSelfMsg -- , init = init -- , onEffects = onEffects --- , cmdMap = (\ _ _ -> Elm.Kernel.Debug.crash 11) -- TODO(harry) crash better here +-- , cmdMap = (\ _ _ -> Elm.Kernel.Platform.subOnlyCmdMap) -- , subMap = subMap -- , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg -- } From d512db52159841c5a3f7990e4c896160feb36ace Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 9 Dec 2019 21:43:58 +0000 Subject: [PATCH 021/170] remove todo's from worker implementation --- src/Platform.elm | 492 +++++++++++++++++++++++------------------------ 1 file changed, 246 insertions(+), 246 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 65c587ce..ec1544c6 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -111,10 +111,10 @@ worker impl = args impl { stepperBuilder = \ _ _ -> (\ _ _ -> ()) - , setupOutgoingPort = Debug.todo "setupOutgoingPort" - , setupIncomingPort = Debug.todo "setupIncomingPort" - , setupEffects = Debug.todo "hiddenSetupEffects" - , dispatchEffects = Debug.todo "dispatchEffects" + , setupOutgoingPort = setupOutgoingPort + , setupIncomingPort = setupIncomingPort + , setupEffects = hiddenSetupEffects + , dispatchEffects = dispatchEffects } ) ) @@ -152,15 +152,15 @@ the main app and your individual effect manager. -} type Router appMsg selfMsg = Router - -- { sendToApp: appMsg -> () - -- , selfProcess: RawScheduler.ProcessId selfMsg - -- } + { sendToApp: appMsg -> () + , selfProcess: RawScheduler.ProcessId selfMsg + } {-| Send the router a message for the main loop of your app. This message will be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () -sendToApp (Router) msg = +sendToApp (Router router) msg = Debug.todo "sendToApp" -- Task -- (RawScheduler.async @@ -185,7 +185,7 @@ effect manager as necessary. As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () -sendToSelf (Router) msg = +sendToSelf (Router router) msg = Debug.todo "sendToSelf" -- Task -- (RawScheduler.andThen @@ -197,239 +197,239 @@ sendToSelf (Router) msg = -- ) --- setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () msg Never --- setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = --- let --- init = --- Task (RawScheduler.Value (Ok ())) - --- onSelfMsg _ selfMsg () = --- never selfMsg - --- execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) --- execInOrder cmdList = --- case cmdList of --- first :: rest -> --- RawScheduler.sync (\() -> --- let --- _ = outgoingPortSend first --- in --- execInOrder rest --- ) - --- _ -> --- RawScheduler.Value (Ok ()) - --- onEffects : Router msg selfMsg --- -> List (HiddenMyCmd msg) --- -> List (HiddenMySub msg) --- -> () --- -> Task Never () --- onEffects _ cmdList _ () = --- let --- typedCmdList = Elm.Kernel.Basics.fudgeType cmdList --- in --- Task (execInOrder typedCmdList) - --- in --- EffectManager --- { onSelfMsg = onSelfMsg --- , init = init --- , onEffects = onEffects --- , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) --- , subMap = (\ _ _ -> Elm.Kernel.Platform.cmdOnlySubMap) --- , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg --- } - - --- setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (EffectManager () msg Never, msg -> List (HiddenMySub msg) -> ()) --- setupIncomingPort sendToApp2 updateSubs = --- let --- init = --- Task (RawScheduler.Value (Ok ())) - --- onSelfMsg _ selfMsg () = --- never selfMsg - --- onEffects _ _ subList () = --- Task --- (RawScheduler.sync --- (\() -> --- let --- _ = updateSubs subList --- in --- RawScheduler.Value (Ok ()) --- ) --- ) - --- onSend : msg -> List (HiddenMySub msg) -> () --- onSend value subs = --- let --- typedSubs : List (msg -> msg) --- typedSubs = --- Elm.Kernel.Basics.fudgeType subs --- in - --- List.foldr --- (\sub () -> sendToApp2 (sub value) AsyncUpdate) --- () --- typedSubs - --- typedSubMap : (msg1 -> msg2) -> (a -> msg1) -> (a -> msg2) --- typedSubMap tagger finalTagger = --- (\val -> tagger (finalTagger val)) - --- subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB --- subMap tagger finalTagger = --- Elm.Kernel.Basics.fudgeType typedSubMap --- in --- (EffectManager --- { onSelfMsg = onSelfMsg --- , init = init --- , onEffects = onEffects --- , cmdMap = (\ _ _ -> Elm.Kernel.Platform.subOnlyCmdMap) --- , subMap = subMap --- , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg --- } --- , onSend --- ) +setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () msg Never +setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = + let + init = + Task (RawScheduler.Value (Ok ())) + + onSelfMsg _ selfMsg () = + never selfMsg + + execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) + execInOrder cmdList = + case cmdList of + first :: rest -> + RawScheduler.sync (\() -> + let + _ = outgoingPortSend first + in + execInOrder rest + ) + + _ -> + RawScheduler.Value (Ok ()) + + onEffects : Router msg selfMsg + -> List (HiddenMyCmd msg) + -> List (HiddenMySub msg) + -> () + -> Task Never () + onEffects _ cmdList _ () = + let + typedCmdList = Elm.Kernel.Basics.fudgeType cmdList + in + Task (execInOrder typedCmdList) + + in + EffectManager + { onSelfMsg = onSelfMsg + , init = init + , onEffects = onEffects + , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) + , subMap = (\ _ _ -> Elm.Kernel.Platform.cmdOnlySubMap) + , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg + } + + +setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (EffectManager () msg Never, msg -> List (HiddenMySub msg) -> ()) +setupIncomingPort sendToApp2 updateSubs = + let + init = + Task (RawScheduler.Value (Ok ())) + + onSelfMsg _ selfMsg () = + never selfMsg + + onEffects _ _ subList () = + Task + (RawScheduler.sync + (\() -> + let + _ = updateSubs subList + in + RawScheduler.Value (Ok ()) + ) + ) + + onSend : msg -> List (HiddenMySub msg) -> () + onSend value subs = + let + typedSubs : List (msg -> msg) + typedSubs = + Elm.Kernel.Basics.fudgeType subs + in + + List.foldr + (\sub () -> sendToApp2 (sub value) AsyncUpdate) + () + typedSubs + + typedSubMap : (msg1 -> msg2) -> (a -> msg1) -> (a -> msg2) + typedSubMap tagger finalTagger = + (\val -> tagger (finalTagger val)) + + subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB + subMap tagger finalTagger = + Elm.Kernel.Basics.fudgeType typedSubMap + in + (EffectManager + { onSelfMsg = onSelfMsg + , init = init + , onEffects = onEffects + , cmdMap = (\ _ _ -> Elm.Kernel.Platform.subOnlyCmdMap) + , subMap = subMap + , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg + } + , onSend + ) -- -- HELPERS -- --- dispatchEffects : OtherManagers msg -> Cmd msg -> Sub msg -> () --- dispatchEffects (OtherManagers processes) cmd sub = --- let --- effectsDict = --- Dict.empty --- |> gatherCmds cmd --- |> gatherSubs sub --- in --- Dict.foldr --- (\key managerProc _ -> --- let --- (cmdList, subList) = --- Maybe.withDefault --- ([], []) --- (Dict.get key effectsDict) --- _ = --- RawScheduler.rawSend --- managerProc --- (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) --- in --- () --- ) --- () --- processes - - --- gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) --- gatherCmds (Cmd.Data cmd) effectsDict = --- cmd --- |> List.foldr --- (\{home, value} dict -> gatherHelper True home value dict) --- effectsDict - - --- gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) --- gatherSubs (Sub.Data subs) effectsDict = --- subs --- |> List.foldr --- (\{home, value} dict -> gatherHelper False home value dict) --- effectsDict - - --- gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) --- gatherHelper isCmd home value effectsDict = --- let --- effectManager = --- getEffectManager home - - --- effect = --- (Elm.Kernel.Basics.fudgeType value) --- in --- Dict.insert --- (effectManagerNameToString home) --- (createEffect isCmd effect (Dict.get (effectManagerNameToString home) effectsDict)) --- effectsDict - - --- createEffect : Bool -> Bag.LeafType msg -> Maybe (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> (List (Bag.LeafType msg), List (Bag.LeafType msg)) --- createEffect isCmd newEffect maybeEffects = --- let --- (cmdList, subList) = --- case maybeEffects of --- Just effects -> effects --- Nothing -> ([], []) --- in --- if isCmd then --- (newEffect :: cmdList, subList) --- else --- (cmdList, newEffect :: subList) - - --- setupEffects : SetupEffects state appMsg selfMsg --- setupEffects sendToAppP init onEffects onSelfMsg cmdMap subMap = --- EffectManager --- { onSelfMsg = onSelfMsg --- , init = init --- , onEffects = onEffects --- , cmdMap = cmdMap --- , subMap = subMap --- , selfProcess = instantiateEffectManager sendToAppP init onEffects onSelfMsg --- } - --- hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg --- hiddenSetupEffects = --- Elm.Kernel.Basics.fudgeType setupEffects - - --- instantiateEffectManager : SendToApp appMsg --- -> Task Never state --- -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) --- -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) --- -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) --- instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = --- let --- receiver msg state = --- let --- (Task task) = --- case msg of --- Self value -> --- onSelfMsg router value state - --- App cmds subs -> --- onEffects router cmds subs state --- in --- RawScheduler.andThen --- (\res -> --- case res of --- Ok val -> --- RawScheduler.andThen --- (\() -> RawScheduler.Value val) --- (RawScheduler.sleep 0) --- Err e -> never e --- ) --- task - - --- selfProcess = --- RawScheduler.rawSpawn ( --- RawScheduler.andThen --- (\() -> init) --- (RawScheduler.sleep 0) --- ) - - --- router = --- Router --- { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) --- , selfProcess = selfProcess --- } --- in --- RawScheduler.rawSetReceiver selfProcess receiver +dispatchEffects : OtherManagers msg -> Cmd msg -> Sub msg -> () +dispatchEffects (OtherManagers processes) cmd sub = + let + effectsDict = + Dict.empty + |> gatherCmds cmd + |> gatherSubs sub + in + Dict.foldr + (\key managerProc _ -> + let + (cmdList, subList) = + Maybe.withDefault + ([], []) + (Dict.get key effectsDict) + _ = + RawScheduler.rawSend + managerProc + (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) + in + () + ) + () + processes + + +gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherCmds (Cmd.Data cmd) effectsDict = + cmd + |> List.foldr + (\{home, value} dict -> gatherHelper True home value dict) + effectsDict + + +gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherSubs (Sub.Data subs) effectsDict = + subs + |> List.foldr + (\{home, value} dict -> gatherHelper False home value dict) + effectsDict + + +gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherHelper isCmd home value effectsDict = + let + effectManager = + getEffectManager home + + + effect = + (Elm.Kernel.Basics.fudgeType value) + in + Dict.insert + (effectManagerNameToString home) + (createEffect isCmd effect (Dict.get (effectManagerNameToString home) effectsDict)) + effectsDict + + +createEffect : Bool -> Bag.LeafType msg -> Maybe (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> (List (Bag.LeafType msg), List (Bag.LeafType msg)) +createEffect isCmd newEffect maybeEffects = + let + (cmdList, subList) = + case maybeEffects of + Just effects -> effects + Nothing -> ([], []) + in + if isCmd then + (newEffect :: cmdList, subList) + else + (cmdList, newEffect :: subList) + + +setupEffects : SetupEffects state appMsg selfMsg +setupEffects sendToAppP init onEffects onSelfMsg cmdMap subMap = + EffectManager + { onSelfMsg = onSelfMsg + , init = init + , onEffects = onEffects + , cmdMap = cmdMap + , subMap = subMap + , selfProcess = instantiateEffectManager sendToAppP init onEffects onSelfMsg + } + +hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg +hiddenSetupEffects = + Elm.Kernel.Basics.fudgeType setupEffects + + +instantiateEffectManager : SendToApp appMsg + -> Task Never state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) + -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) +instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = + let + receiver msg state = + let + (Task task) = + case msg of + Self value -> + onSelfMsg router value state + + App cmds subs -> + onEffects router cmds subs state + in + RawScheduler.andThen + (\res -> + case res of + Ok val -> + RawScheduler.andThen + (\() -> RawScheduler.Value val) + (RawScheduler.sleep 0) + Err e -> never e + ) + task + + + selfProcess = + RawScheduler.rawSpawn ( + RawScheduler.andThen + (\() -> init) + (RawScheduler.sleep 0) + ) + + + router = + Router + { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) + , selfProcess = selfProcess + } + in + RawScheduler.rawSetReceiver selfProcess receiver type alias SendToApp msg = @@ -555,16 +555,16 @@ makeProgramCallable (Program program) = Elm.Kernel.Basics.fudgeType program --- effectManagerNameToString : Bag.EffectManagerName -> String --- effectManagerNameToString = --- Elm.Kernel.Platform.effectManagerNameToString +effectManagerNameToString : Bag.EffectManagerName -> String +effectManagerNameToString = + Elm.Kernel.Platform.effectManagerNameToString --- getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg --- getEffectManager = --- Elm.Kernel.Platform.getEffectManager +getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg +getEffectManager = + Elm.Kernel.Platform.getEffectManager --- effectManagerFold : (Bag.EffectManagerName -> EffectManager state appMsg selfMsg -> a -> a) -> a -> a --- effectManagerFold = --- Elm.Kernel.Platform.effectManagerFold +effectManagerFold : (Bag.EffectManagerName -> EffectManager state appMsg selfMsg -> a -> a) -> a -> a +effectManagerFold = + Elm.Kernel.Platform.effectManagerFold From 5c899ea03e0e5200618d7ae260f71de97b44cf4f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 9 Dec 2019 21:55:30 +0000 Subject: [PATCH 022/170] fix some bugs in kernel code --- src/Elm/Kernel/Platform.js | 25 ++++++++++++------------- src/Elm/Kernel/Scheduler.js | 18 +++++++++++++----- 2 files changed, 25 insertions(+), 18 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index c588b1c5..b788898e 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -18,8 +18,7 @@ var _Platform_compiledEffectManagers = {}; // INITIALIZE A PROGRAM -function _Platform_initialize(flagDecoder, args, impl, functions) -{ +const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); @@ -28,10 +27,18 @@ function _Platform_initialize(flagDecoder, args, impl, functions) __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); } + const sendToApp = F2((msg, viewMetadata) => { + const updateValue = A2(impl.__$update, msg, model); + model = updateValue.a + A2(stepper, model, viewMetadata); + A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); + }); + const managers = {}; const ports = {}; + const initValue = impl.__$init(flagsResult.a); - var model = initValue.a; + let model = initValue.a; const stepper = A2(functions.__$stepperBuilder, sendToApp, model); for (var key in _Platform_effectManagers) @@ -57,18 +64,10 @@ function _Platform_initialize(flagDecoder, args, impl, functions) ports[key] = setup.ports; managers[key] = setup.manger; } - - const sendToApp = F2((msg, viewMetadata) => { - const updateValue = A2(impl.__$update, msg, model); - model = updateValue.a - A2(stepper, model, viewMetadata); - A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); - }) - A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); return ports ? { ports: ports } : {}; -} +}); @@ -245,7 +244,7 @@ function _Platform_outgoingPort(name, converter) } const outgoingPortSend = payload => { - var value = __Json_unwrap(payload); + var value = __Json_unwrap(converter(payload)); for (const sub of subs) { sub(value); diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index a4cbf45e..4185392e 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -47,7 +47,12 @@ function _Scheduler_getProcessState(id) { } var _Scheduler_updateProcessState = F2((func, id) => { - const procState = _Scheduler_getProcessState.get(id); + const procState = _Scheduler_processes.get(id); + /**__DEBUG/ + if (procState === undefined) { + __Debug_crash(12, 'procIdNotRegistered'); + } + //*/ _Scheduler_processes.set(id, func(procState)); return procState; }); @@ -74,12 +79,15 @@ var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) return; } _Scheduler_working = true; - while (procId = _Scheduler_queue.shift()) + while (true) { - stepper(procId); + const newProcId = _Scheduler_queue.shift(); + if (newProcId === undefined) { + _Scheduler_working = false; + return procId; + } + stepper(newProcId); } - _Scheduler_working = false; - return procId; }); From dd01f49a613bed15d2098371e5d66cf144d263cc Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 9 Dec 2019 21:56:08 +0000 Subject: [PATCH 023/170] avoid triggering todo by wrapping in lambda --- src/Platform/RawScheduler.elm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 03c1cab7..542340e5 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -291,7 +291,7 @@ stepper (ProcessId processId) (ProcessState process) = killableRoot = AsyncAction - (Debug.todo "put an assert(false) function here?") + (\_ -> Debug.todo "put an assert(false) function here?") (doEffect (\newRoot -> let -- todo: avoid enqueue here From 7ba9d3c2a213383df5017ecf687c5a5aea20ffb7 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 9 Dec 2019 22:11:54 +0000 Subject: [PATCH 024/170] fix more runtime bugs --- src/Elm/Kernel/Debug.js | 4 ++-- src/Elm/Kernel/Platform.js | 2 +- src/Elm/Kernel/Scheduler.js | 10 ++++++---- src/Platform/RawScheduler.elm | 29 +++++++++++++++++------------ 4 files changed, 26 insertions(+), 19 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 963d5abc..2e0b56cd 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -312,10 +312,10 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) throw new Error('Bug in elm runtime: attempting to cmdMap subscription only effect module.'); case 'procIdAlreadyRegistered': - throw new Error(`Bug in elm runtime: state for process ${fact1} is already registered!`); + throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); case 'procIdNotRegistered': - throw new Error(`Bug in elm runtime: state for process ${fact1} has not registered!`); + throw new Error(`Bug in elm runtime: state for process ${fact2} has not registered!`); } throw new Error(`Unknown bug in elm runtime id: ${identifier}!`); } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index b788898e..bb4fce63 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -64,7 +64,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { ports[key] = setup.ports; managers[key] = setup.manger; } - A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); + A3(functions.__$dispatchEffects, managers, initValue.b, impl.__$subscriptions(model)); return ports ? { ports: ports } : {}; }); diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 4185392e..5f90cb94 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -33,24 +33,25 @@ var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); function _Scheduler_getGuid() { - return Object.create({ id: _Scheduler_guid++ }); + return _Scheduler_guid++; } function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered'); + __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.id); } //*/ return procState; } var _Scheduler_updateProcessState = F2((func, id) => { + console.log("update", id); const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered'); + __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.id); } //*/ _Scheduler_processes.set(id, func(procState)); @@ -58,9 +59,10 @@ var _Scheduler_updateProcessState = F2((func, id) => { }); var _Scheduler_registerNewProcess = F2((procId, procState) => { + console.log("registering", procId); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdAlreadyRegistered'); + __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.id); } //*/ _Scheduler_processes.set(procId, procState); diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 542340e5..bd4adb6e 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -134,12 +134,14 @@ Will modify an existing process, **enqueue** and return it. -} rawSetReceiver : ProcessId msg -> (msg -> a -> Task a) -> ProcessId msg -rawSetReceiver proc receiver = - enqueue - (updateProcessState - (\(ProcessState state) -> ProcessState { state | receiver = Just (Elm.Kernel.Basics.fudgeType receiver) } ) - proc - ) +rawSetReceiver processId receiver = + let + _ = + updateProcessState + (\(ProcessState state) -> ProcessState { state | receiver = Just (Elm.Kernel.Basics.fudgeType receiver) } ) + processId + in + enqueue processId {-| NON PURE! @@ -150,11 +152,14 @@ can perform actions based on the message. -} rawSend : ProcessId msg -> msg-> ProcessId msg rawSend processId msg = - enqueue - (updateProcessState - (\(ProcessState procState) -> ProcessState { procState | mailbox = procState.mailbox ++ [msg]}) - processId - ) + let + _ = + updateProcessState + (\(ProcessState procState) -> ProcessState { procState | mailbox = procState.mailbox ++ [msg]}) + processId + in + enqueue processId + {-| Create a task, if run, will make the process deal with a message. @@ -346,7 +351,7 @@ stepper (ProcessId processId) (ProcessState process) = -- Kernel function redefinitons -- -updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessId msg +updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state updateProcessState = Elm.Kernel.Scheduler.updateProcessState From b94ef17398a39438b019cee8608f94888b800781 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 9 Dec 2019 23:33:00 +0000 Subject: [PATCH 025/170] dispatch fixing --- src/Elm/Kernel/Platform.js | 6 +++- src/Platform.elm | 59 +++++++++++++++++--------------------- 2 files changed, 32 insertions(+), 33 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index bb4fce63..fbcad184 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -64,7 +64,11 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { ports[key] = setup.ports; managers[key] = setup.manger; } - A3(functions.__$dispatchEffects, managers, initValue.b, impl.__$subscriptions(model)); + const dispatcher = A3(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); + + for (const key in mangers) { + A2(dispatcher, key, mangers); + } return ports ? { ports: ports } : {}; }); diff --git a/src/Platform.elm b/src/Platform.elm index ec1544c6..f2a79868 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -298,46 +298,46 @@ setupIncomingPort sendToApp2 updateSubs = -- -- HELPERS -- -dispatchEffects : OtherManagers msg -> Cmd msg -> Sub msg -> () -dispatchEffects (OtherManagers processes) cmd sub = +dispatchEffects : Cmd appMsg + -> Sub appMsg + -> Bag.EffectManagerName + -> Router appMsg (ReceivedData appMsg HiddenSelfMsg) + -> () +dispatchEffects cmd sub = let effectsDict = Dict.empty |> gatherCmds cmd |> gatherSubs sub in - Dict.foldr - (\key managerProc _ -> - let - (cmdList, subList) = - Maybe.withDefault - ([], []) - (Dict.get key effectsDict) - _ = - RawScheduler.rawSend - managerProc - (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) - in - () - ) - () - processes + \key (Router { selfProcess }) -> + let + (cmdList, subList) = + Maybe.withDefault + ([], []) + (Dict.get (effectManagerNameToString key) effectsDict) + _ = + RawScheduler.rawSend + selfProcess + (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) + in + () gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) gatherCmds (Cmd.Data cmd) effectsDict = - cmd - |> List.foldr - (\{home, value} dict -> gatherHelper True home value dict) - effectsDict + List.foldr + (\{home, value} dict -> gatherHelper True home value dict) + effectsDict + (Debug.log "cmds" cmd) gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) gatherSubs (Sub.Data subs) effectsDict = - subs - |> List.foldr - (\{home, value} dict -> gatherHelper False home value dict) - effectsDict + List.foldr + (\{home, value} dict -> gatherHelper False home value dict) + effectsDict + (Debug.log "subs" subs) gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) @@ -530,7 +530,7 @@ type alias InitFunctions model appMsg = , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg - , dispatchEffects : OtherManagers appMsg -> Cmd appMsg -> Sub appMsg -> () + , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> Router appMsg (ReceivedData appMsg HiddenSelfMsg) -> () } -- -- kernel -- @@ -563,8 +563,3 @@ effectManagerNameToString = getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg getEffectManager = Elm.Kernel.Platform.getEffectManager - - -effectManagerFold : (Bag.EffectManagerName -> EffectManager state appMsg selfMsg -> a -> a) -> a -> a -effectManagerFold = - Elm.Kernel.Platform.effectManagerFold From 52953413295dc438ad0338df80266d7881525717 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 14 Dec 2019 13:15:35 +0000 Subject: [PATCH 026/170] rework elm/js devide for effect managers --- src/Elm/Kernel/Platform.js | 78 ++++++++++++++++++++++---------------- src/Platform.elm | 51 +++++-------------------- src/Platform/Cmd.elm | 24 ++++++++---- src/Platform/Sub.elm | 25 +++++++----- 4 files changed, 88 insertions(+), 90 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index fbcad184..90815647 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -13,12 +13,14 @@ import Result exposing (isOk) var _Platform_outgoingPorts = {}; var _Platform_incomingPorts = {}; var _Platform_effectManagers = {}; -var _Platform_compiledEffectManagers = {}; -// INITIALIZE A PROGRAM +const _Platform_cmdMappers = {}; +const _Platform_subMappers = {}; +// INITIALIZE A PROGRAM const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { + // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); @@ -31,7 +33,12 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { const updateValue = A2(impl.__$update, msg, model); model = updateValue.a A2(stepper, model, viewMetadata); - A3(functions.__$dispatchEffects, managers, updateValue.b, impl.__$subscriptions(model)); + + const dispatcher = A3(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); + + for (const key in managers) { + A2(dispatcher, key, managers[key]); + } }); const managers = {}; @@ -43,31 +50,26 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { for (var key in _Platform_effectManagers) { - const setup = _Platform_effectManagers[key]; - _Platform_compiledEffectManagers[key] = - setup(functions.__$setupEffects, sendToApp); - managers[key] = setup; + const setup = _Platform_effectManagers[key].__setup; + managers[key] = setup(functions.__$setupEffects, sendToApp); } for (var key in _Platform_outgoingPorts) { - const setup = _Platform_outgoingPorts[key]; - _Platform_compiledEffectManagers[key] = - setup(functions.__$setupOutgoingPort, sendToApp); + const setup = _Platform_outgoingPorts[key](functions.__$setupOutgoingPort, sendToApp); ports[key] = setup.ports; - managers[key] = setup.manger; + managers[key] = setup.manager; } for (var key in _Platform_incomingPorts) { - const setup = _Platform_incomingPorts[key]; - _Platform_compiledEffectManagers[key] = - setup(functions.__$setupIncomingPort, sendToApp); + const setup = _Platform_incomingPorts[key](functions.__$setupIncomingPort, sendToApp); ports[key] = setup.ports; - managers[key] = setup.manger; + managers[key] = setup.manager; } const dispatcher = A3(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); - for (const key in mangers) { - A2(dispatcher, key, mangers); + for (const key in managers) { + console.log(managers[key]); + A2(dispatcher, key, managers[key]); } return ports ? { ports: ports } : {}; @@ -95,11 +97,6 @@ function _Platform_registerPreload(url) // EFFECT MANAGERS - -function _Platform_getEffectManager(name) { - return _Platform_compiledEffectManagers[name]; -} - function _Platform_effectManagerNameToString(name) { return name; } @@ -121,6 +118,22 @@ const _Platform_cmdOnlySubMap = F2(function(_1, _2) { }); +const _Platform_getCmdMapper = F2(function(portCmdMapper, home) { + if (_Platform_outgoingPorts.hasOwnProperty(home)) { + return portCmdMapper; + } + return _Platform_effectManagers[home].__cmdMapper; +}); + + +const _Platform_getSubMapper = F2(function(portSubMapper, home) { + if (_Platform_incomingPorts.hasOwnProperty(home)) { + return portSubMapper; + } + return _Platform_effectManagers[home].__subMapper; +}); + + // Called by compiler generated js when creating event mangers function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { @@ -132,7 +145,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) return A3(onEffects, router, subs, state); }); fullCmdMap = _Platform_subOnlyCmdMap; - fullSubMap = subMap; + _Platform = subMap; } else if (subMap === undefined) { // Command only effect module fullOnEffects = F4(function(router, cmds, subs, state) { @@ -145,9 +158,14 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) fullCmdMap = cmdMap; fullSubMap = subMap; } + // Command **and** subscription event manager - return function(setup, sendToApp) { - return A6(setup, sendToApp, init, fullOnEffects, onSelfMsg, fullCmdMap, fullSubMap) + return { + __cmdMapper: fullCmdMap, + __subMapper: fullSubMap, + __setup: function(setup, sendToApp) { + return A4(setup, sendToApp, init, fullOnEffects, onSelfMsg) + } }; } @@ -174,9 +192,7 @@ function _Platform_leaf(home) b: { $: __2_LEAFTYPE, a: value - }, - c: _Platform_compiledEffectManagers[home].__$cmdMap, - d: _Platform_compiledEffectManagers[home].__$subMap + } }, b: { $: '[]' @@ -198,9 +214,7 @@ function _Platform_leaf(home) b: { $: __2_LEAFTYPE, a: value - }, - c: _Platform_compiledEffectManagers[home].__$cmdMap, - d: _Platform_compiledEffectManagers[home].__$subMap + } }, b: { $: 0 @@ -217,7 +231,7 @@ function _Platform_leaf(home) function _Platform_checkPortName(name) { - if (_Platform_compiledEffectManagers[name]) + if (_Platform_effectManagers[name]) { __Debug_crash(3, name) } diff --git a/src/Platform.elm b/src/Platform.elm index f2a79868..dbeaa1c0 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -197,7 +197,7 @@ sendToSelf (Router router) msg = -- ) -setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () msg Never +setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData msg Never) setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = let init = @@ -232,17 +232,10 @@ setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = Task (execInOrder typedCmdList) in - EffectManager - { onSelfMsg = onSelfMsg - , init = init - , onEffects = onEffects - , cmdMap = (\ _ value -> Elm.Kernel.Basics.fudgeType value) - , subMap = (\ _ _ -> Elm.Kernel.Platform.cmdOnlySubMap) - , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg - } + instantiateEffectManager sendToApp2 init onEffects onSelfMsg -setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (EffectManager () msg Never, msg -> List (HiddenMySub msg) -> ()) +setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (RawScheduler.ProcessId (ReceivedData msg Never), msg -> List (HiddenMySub msg) -> ()) setupIncomingPort sendToApp2 updateSubs = let init = @@ -283,14 +276,7 @@ setupIncomingPort sendToApp2 updateSubs = subMap tagger finalTagger = Elm.Kernel.Basics.fudgeType typedSubMap in - (EffectManager - { onSelfMsg = onSelfMsg - , init = init - , onEffects = onEffects - , cmdMap = (\ _ _ -> Elm.Kernel.Platform.subOnlyCmdMap) - , subMap = subMap - , selfProcess = instantiateEffectManager sendToApp2 init onEffects onSelfMsg - } + ( instantiateEffectManager sendToApp2 init onEffects onSelfMsg , onSend ) @@ -343,10 +329,6 @@ gatherSubs (Sub.Data subs) effectsDict = gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) gatherHelper isCmd home value effectsDict = let - effectManager = - getEffectManager home - - effect = (Elm.Kernel.Basics.fudgeType value) in @@ -371,15 +353,9 @@ createEffect isCmd newEffect maybeEffects = setupEffects : SetupEffects state appMsg selfMsg -setupEffects sendToAppP init onEffects onSelfMsg cmdMap subMap = - EffectManager - { onSelfMsg = onSelfMsg - , init = init - , onEffects = onEffects - , cmdMap = cmdMap - , subMap = subMap - , selfProcess = instantiateEffectManager sendToAppP init onEffects onSelfMsg - } +setupEffects sendToAppP init onEffects onSelfMsg = + instantiateEffectManager sendToAppP init onEffects onSelfMsg + hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg hiddenSetupEffects = @@ -520,15 +496,13 @@ type alias SetupEffects state appMsg selfMsg = -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB) - -> ((HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB) - -> EffectManager state appMsg selfMsg + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) - , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> EffectManager () appMsg Never - , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (EffectManager () appMsg Never, appMsg -> List (HiddenMySub appMsg) -> ()) + , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData appMsg Never) + , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (RawScheduler.ProcessId (ReceivedData appMsg Never), appMsg -> List (HiddenMySub appMsg) -> ()) , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> Router appMsg (ReceivedData appMsg HiddenSelfMsg) -> () } @@ -558,8 +532,3 @@ makeProgramCallable (Program program) = effectManagerNameToString : Bag.EffectManagerName -> String effectManagerNameToString = Elm.Kernel.Platform.effectManagerNameToString - - -getEffectManager : Bag.EffectManagerName -> EffectManager state appMsg selfMsg -getEffectManager = - Elm.Kernel.Platform.getEffectManager diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 23db2bbe..9db4a3a3 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -54,8 +54,6 @@ type Cmd msg (List { home : Bag.EffectManagerName , value : (Bag.LeafType msg) - , cmdMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB - , subMapper : Never } ) @@ -97,23 +95,33 @@ map : (a -> msg) -> Cmd a -> Cmd msg map fn (Data data) = data |> List.map - (\{home, value, cmdMapper, subMapper} -> + (\{home, value} -> { home = home - , value = (fudgeCmdMapperType cmdMapper) fn value - , cmdMapper = cmdMapper - , subMapper = subMapper + , value = (getCmdMapper home) fn value } ) |> Data + -- HELPERS -- + type HiddenA = HiddenA Never type HiddenB = HiddenB Never -fudgeCmdMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) -fudgeCmdMapperType = +outgoingPortCmdMap : (a -> b) -> Bag.LeafType a -> Bag.LeafType msg +outgoingPortCmdMap _ value = + fudgeLeafType value + + +getCmdMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg +getCmdMapper home = + Elm.Kernel.Platform.getCmdMapper outgoingPortCmdMap home + + +fudgeLeafType : Bag.LeafType a -> Bag.LeafType b +fudgeLeafType = Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index e36c25ea..b24f1c24 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -55,8 +55,6 @@ type Sub msg (List { home : Bag.EffectManagerName , value : (Bag.LeafType msg) - , cmdMapper : Never - , subMapper : (HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB } ) @@ -99,12 +97,9 @@ map : (a -> msg) -> Sub a -> Sub msg map fn (Data data) = data |> List.map - (\{home, value, cmdMapper, subMapper} -> + (\{home, value} -> { home = home - , value = (fudgeSubMapperType subMapper) fn value - , cmdMapper = cmdMapper - , subMapper = subMapper - } + , value = (getSubMapper home) fn value} ) |> Data @@ -115,7 +110,19 @@ type HiddenA = HiddenA Never type HiddenB = HiddenB Never +outgoingPortSubMap : (a -> b) -> (data -> a) -> (data -> b) +outgoingPortSubMap tagger finalTagger = + (\val -> tagger (finalTagger val)) -fudgeSubMapperType : ((HiddenA -> HiddenB) -> Bag.LeafType HiddenA -> Bag.LeafType HiddenB) -> ((a -> msg) -> (Bag.LeafType a -> Bag.LeafType msg)) -fudgeSubMapperType = +fudgedOutgoingPortSubMap : (a -> b) -> Bag.LeafType a -> Bag.LeafType b +fudgedOutgoingPortSubMap tagger finalTagger = + Elm.Kernel.Basics.fudgeType outgoingPortSubMap + +getSubMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg +getSubMapper home = + Elm.Kernel.Platform.getSubMapper fudgedOutgoingPortSubMap home + + +fudgeLeafType : Bag.LeafType a -> Bag.LeafType b +fudgeLeafType = Elm.Kernel.Basics.fudgeType From 7947b8b00f85499c62ea221941de00ef6f21702e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 15 Dec 2019 22:10:29 +0000 Subject: [PATCH 027/170] fix bugs with sending data to processes --- src/Elm/Kernel/Debug.js | 2 +- src/Elm/Kernel/Platform.js | 37 ++++++----------- src/Elm/Kernel/Scheduler.js | 5 ++- src/Platform.elm | 23 ++++++----- src/Platform/RawScheduler.elm | 78 +++++++++++++++++++++++------------ 5 files changed, 79 insertions(+), 66 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 2e0b56cd..8cd4a9c7 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -315,7 +315,7 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); case 'procIdNotRegistered': - throw new Error(`Bug in elm runtime: state for process ${fact2} has not registered!`); + throw new Error(`Bug in elm runtime: state for process ${fact2} been has not registered!`); } throw new Error(`Unknown bug in elm runtime id: ${identifier}!`); } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 90815647..3cb52b19 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -34,9 +34,10 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { model = updateValue.a A2(stepper, model, viewMetadata); - const dispatcher = A3(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); + const dispatcher = A2(functions.__$dispatchEffects, updateValue.b, impl.__$subscriptions(model)); for (const key in managers) { + // console.log(managers[key]); A2(dispatcher, key, managers[key]); } }); @@ -65,10 +66,11 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { ports[key] = setup.ports; managers[key] = setup.manager; } - const dispatcher = A3(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); + // console.log('managers', managers); + const dispatcher = A2(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); for (const key in managers) { - console.log(managers[key]); + // console.log(managers[key]); A2(dispatcher, key, managers[key]); } @@ -98,6 +100,7 @@ function _Platform_registerPreload(url) function _Platform_effectManagerNameToString(name) { + console.log("effect to string", name); return name; } @@ -185,14 +188,8 @@ function _Platform_leaf(home) a: { $: '::', a: { - a: { - $: __1_EFFECTMANAGERNAME, - a: home - }, - b: { - $: __2_LEAFTYPE, - a: value - } + __$home: home, + __$value: value }, b: { $: '[]' @@ -207,14 +204,8 @@ function _Platform_leaf(home) a: { $: 1, a: { - a: { - $: __1_EFFECTMANAGERNAME, - a: home - }, - b: { - $: __2_LEAFTYPE, - a: value - } + __$home: home, + __$value: value }, b: { $: 0 @@ -271,14 +262,10 @@ function _Platform_outgoingPort(name, converter) }; - const manager = A3( + const manager = A2( setup, sendToApp, - outgoingPortSend, - { - subscribe: subscribe, - unsubscribe: unsubscribe - }, + outgoingPortSend ); return { diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 5f90cb94..38c41629 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -37,6 +37,7 @@ function _Scheduler_getGuid() { } function _Scheduler_getProcessState(id) { + // console.log("get", id); const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { @@ -47,8 +48,8 @@ function _Scheduler_getProcessState(id) { } var _Scheduler_updateProcessState = F2((func, id) => { - console.log("update", id); const procState = _Scheduler_processes.get(id); + // console.log("update", id, procState); /**__DEBUG/ if (procState === undefined) { __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.id); @@ -59,7 +60,7 @@ var _Scheduler_updateProcessState = F2((func, id) => { }); var _Scheduler_registerNewProcess = F2((procId, procState) => { - console.log("registering", procId); + // console.log("registering", procId); /**__DEBUG/ if (procState === undefined) { __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.id); diff --git a/src/Platform.elm b/src/Platform.elm index dbeaa1c0..b9ea02b5 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -197,8 +197,8 @@ sendToSelf (Router router) msg = -- ) -setupOutgoingPort : SendToApp msg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData msg Never) -setupOutgoingPort sendToApp2 outgoingPort outgoingPortSend = +setupOutgoingPort : SendToApp msg -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData msg Never) +setupOutgoingPort sendToApp2 outgoingPortSend = let init = Task (RawScheduler.Value (Ok ())) @@ -287,16 +287,17 @@ setupIncomingPort sendToApp2 updateSubs = dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> Router appMsg (ReceivedData appMsg HiddenSelfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () dispatchEffects cmd sub = let effectsDict = Dict.empty - |> gatherCmds cmd + |> gatherCmds (Debug.log "cmd" cmd) |> gatherSubs sub + |> Debug.log "effects dict" in - \key (Router { selfProcess }) -> + \key selfProcess-> let (cmdList, subList) = Maybe.withDefault @@ -311,11 +312,11 @@ dispatchEffects cmd sub = gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherCmds (Cmd.Data cmd) effectsDict = +gatherCmds (Cmd.Data cmds) effectsDict = List.foldr (\{home, value} dict -> gatherHelper True home value dict) effectsDict - (Debug.log "cmds" cmd) + cmds -- (Debug.log "cmds" cmds) gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) @@ -323,7 +324,7 @@ gatherSubs (Sub.Data subs) effectsDict = List.foldr (\{home, value} dict -> gatherHelper False home value dict) effectsDict - (Debug.log "subs" subs) + subs -- (Debug.log "subs" subs) gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) @@ -394,7 +395,7 @@ instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = selfProcess = RawScheduler.rawSpawn ( RawScheduler.andThen - (\() -> init) + (\() -> Debug.log "init from instantiate" init) (RawScheduler.sleep 0) ) @@ -501,10 +502,10 @@ type alias SetupEffects state appMsg selfMsg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) - , setupOutgoingPort : SendToApp appMsg -> (RawJsObject Never -> ()) -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData appMsg Never) + , setupOutgoingPort : SendToApp appMsg -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData appMsg Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (RawScheduler.ProcessId (ReceivedData appMsg Never), appMsg -> List (HiddenMySub appMsg) -> ()) , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg - , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> Router appMsg (ReceivedData appMsg HiddenSelfMsg) -> () + , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () } -- -- kernel -- diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index bd4adb6e..79a8f443 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -62,7 +62,7 @@ type ProcessState msg state { root : Task state , stack : List (HiddenValB -> Task HiddenValC) , mailbox : List msg - , receiver : Maybe (msg -> Task state) + , receiver : Maybe (msg -> state -> Task state) } @@ -138,7 +138,10 @@ rawSetReceiver processId receiver = let _ = updateProcessState - (\(ProcessState state) -> ProcessState { state | receiver = Just (Elm.Kernel.Basics.fudgeType receiver) } ) + (\(ProcessState state) -> + ProcessState + { state | receiver = Just receiver } + ) processId in enqueue processId @@ -155,7 +158,10 @@ rawSend processId msg = let _ = updateProcessState - (\(ProcessState procState) -> ProcessState { procState | mailbox = procState.mailbox ++ [msg]}) + (\(ProcessState procState) -> + ProcessState + { procState | mailbox = procState.mailbox ++ [msg]} + ) processId in enqueue processId @@ -263,26 +269,28 @@ the process it is passed as an argument -} stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state -stepper (ProcessId processId) (ProcessState process) = +stepper processId (ProcessState process) = let - (ProcessState steppedProcess) = - case process.root of + (ProcessState steppedProcess, maybeFinalValue) = + case {- Debug.log "root" -} process.root of Value val -> let moveStackFowards stack = case stack of callback :: rest -> - stepper - (ProcessId processId) - (ProcessState + ( stepper + processId + ( ProcessState { process | root = (Elm.Kernel.Basics.fudgeType (callback (Elm.Kernel.Basics.fudgeType val))) , stack = rest } ) + , Nothing + ) _ -> - (ProcessState process) + (ProcessState process, Just val) in moveStackFowards process.stack @@ -291,7 +299,7 @@ stepper (ProcessId processId) (ProcessState process) = let newProcess = { process - | root = killableRoot + | root = {- Debug.log "killableRoot" -} killableRoot } killableRoot = @@ -299,52 +307,68 @@ stepper (ProcessId processId) (ProcessState process) = (\_ -> Debug.todo "put an assert(false) function here?") (doEffect (\newRoot -> let - -- todo: avoid enqueue here _ = - enqueue - (Elm.Kernel.Scheduler.register - (ProcessState { process | root = newRoot }) + (updateProcessState + (\(ProcessState p) -> + ProcessState + { p | root = {- Debug.log "newRoot" -} newRoot } + ) + processId ) in + let + -- todo: avoid enqueue here + _ = + enqueue processId + in () )) in - ProcessState newProcess + (ProcessState newProcess, Nothing) SyncAction doEffect-> let newProcess = { process - | root = doEffect () + | root = {- Debug.log "syncRoot" -} (doEffect ()) } in - ProcessState newProcess + ( stepper + processId + (ProcessState newProcess) + , Nothing + ) AndThen callback task -> - stepper - (ProcessId processId) + ( stepper + processId (ProcessState { process - | root = task + | root = {- Debug.log "andThenRoot" -} task , stack = (Elm.Kernel.Basics.fudgeType callback) :: process.stack } ) + , Nothing + ) in - case (steppedProcess.mailbox, steppedProcess.receiver) of - (first :: rest, Just receiver) -> + case (steppedProcess.mailbox, maybeFinalValue, steppedProcess.receiver) of + (first :: rest, Just val, Just receiver) -> stepper - (ProcessId processId) + processId (ProcessState { process - | root = receiver first + | root = {- Debug.log "receiverRoot" -} (receiver first val) , mailbox = rest } ) - ([], _) -> + ([], _, _) -> + ProcessState process + + (_, Nothing, _) -> ProcessState process - (_, Nothing) -> + (_, _, Nothing) -> ProcessState process From 653da0ef15e660e47c54e7b23afbab12183035b1 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Dec 2019 22:34:08 +0000 Subject: [PATCH 028/170] getting there Need to rework our task data type though --- src/Elm/Kernel/Debug.js | 3 ++ src/Elm/Kernel/Platform.js | 2 +- src/Elm/Kernel/Scheduler.js | 8 ++++-- src/Platform.elm | 54 ++++++++++++++--------------------- src/Platform/RawScheduler.elm | 7 +++-- src/Platform/Scheduler.elm | 1 - src/Task.elm | 1 - 7 files changed, 37 insertions(+), 39 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 8cd4a9c7..d809c1b7 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -316,6 +316,9 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) case 'procIdNotRegistered': throw new Error(`Bug in elm runtime: state for process ${fact2} been has not registered!`); + + case 'cannotBeStepped': + throw new Error(`Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!`); } throw new Error(`Unknown bug in elm runtime id: ${identifier}!`); } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 3cb52b19..f83c108d 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -100,7 +100,7 @@ function _Platform_registerPreload(url) function _Platform_effectManagerNameToString(name) { - console.log("effect to string", name); + // console.log("effect to string", name); return name; } diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 38c41629..97bae41c 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -52,7 +52,7 @@ var _Scheduler_updateProcessState = F2((func, id) => { // console.log("update", id, procState); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.id); + __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.__$id); } //*/ _Scheduler_processes.set(id, func(procState)); @@ -63,7 +63,7 @@ var _Scheduler_registerNewProcess = F2((procId, procState) => { // console.log("registering", procId); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.id); + __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); } //*/ _Scheduler_processes.set(procId, procState); @@ -102,3 +102,7 @@ var _Scheduler_delay = F3(function (time, value, callback) return function(x) { clearTimeout(id); return x; }; }); + +const _Scheduler_cannotBeStepped = F2((procId, _1) => { + __Debug_crash(12, 'cannotBeStepped', procId && procId.a && procId.a.__$id) +}); diff --git a/src/Platform.elm b/src/Platform.elm index b9ea02b5..7ca0f667 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -39,13 +39,10 @@ import String exposing (String) import Char exposing (Char) import Tuple -import Debug - import Platform.Cmd as Cmd exposing ( Cmd ) import Platform.Sub as Sub exposing ( Sub ) import Elm.Kernel.Basics -import Elm.Kernel.Debug import Elm.Kernel.Platform import Platform.Bag as Bag -- import Json.Decode exposing (Decoder) @@ -161,21 +158,16 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Debug.todo "sendToApp" - -- Task - -- (RawScheduler.async - -- (\doneCallback -> - -- let - -- _ = - -- router.sendToApp msg - -- in - -- let - -- _ = - -- doneCallback (RawScheduler.Value (Ok ())) - -- in - -- (\() -> ()) - -- ) - -- ) + Task + (RawScheduler.sync + (\() -> + let + _ = + router.sendToApp msg + in + RawScheduler.Value (Ok ()) + ) + ) {-| Send the router a message for your effect manager. This message will @@ -186,15 +178,14 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Debug.todo "sendToSelf" - -- Task - -- (RawScheduler.andThen - -- (\() -> RawScheduler.Value (Ok ())) - -- (RawScheduler.send - -- router.selfProcess - -- msg - -- ) - -- ) + Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.send + router.selfProcess + msg + ) + ) setupOutgoingPort : SendToApp msg -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData msg Never) @@ -293,9 +284,8 @@ dispatchEffects cmd sub = let effectsDict = Dict.empty - |> gatherCmds (Debug.log "cmd" cmd) + |> gatherCmds cmd |> gatherSubs sub - |> Debug.log "effects dict" in \key selfProcess-> let @@ -316,7 +306,7 @@ gatherCmds (Cmd.Data cmds) effectsDict = List.foldr (\{home, value} dict -> gatherHelper True home value dict) effectsDict - cmds -- (Debug.log "cmds" cmds) + cmds gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) @@ -324,7 +314,7 @@ gatherSubs (Sub.Data subs) effectsDict = List.foldr (\{home, value} dict -> gatherHelper False home value dict) effectsDict - subs -- (Debug.log "subs" subs) + subs gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) @@ -395,7 +385,7 @@ instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = selfProcess = RawScheduler.rawSpawn ( RawScheduler.andThen - (\() -> Debug.log "init from instantiate" init) + (\() -> init) (RawScheduler.sleep 0) ) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 79a8f443..a317c904 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -40,7 +40,6 @@ import Basics exposing (..) import Maybe exposing (Maybe(..)) import Elm.Kernel.Basics import Elm.Kernel.Scheduler -import Debug import List exposing ((::)) type Task val @@ -304,7 +303,7 @@ stepper processId (ProcessState process) = killableRoot = AsyncAction - (\_ -> Debug.todo "put an assert(false) function here?") + (cannotBeStepped processId) (doEffect (\newRoot -> let _ = @@ -398,3 +397,7 @@ enqueueWithStepper = delay : Float -> Task val -> DoneCallback val -> TryAbortAction delay = Elm.Kernel.Scheduler.delay + +cannotBeStepped : ProcessId msg -> DoneCallback state -> TryAbortAction +cannotBeStepped = + Elm.Kernel.Scheduler.cannotBeStepped diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 19c7e32a..e89723c5 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -13,7 +13,6 @@ import Platform import Platform.RawScheduler as RawScheduler import Result exposing (Result(..)) import Basics exposing (..) -import Debug type alias ProcessId msg diff --git a/src/Task.elm b/src/Task.elm index 6eb124ae..688950e6 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -25,7 +25,6 @@ HTTP requests or writing to a database. -} -import Debug import Basics exposing (Never, (|>), (<<)) import List exposing ((::)) import Maybe exposing (Maybe(..)) From 5ed86b6b75f597c0608454b7382efef9b34e9482 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Dec 2019 23:37:03 +0000 Subject: [PATCH 029/170] entirely new scheduler uses an more elmy Task based on functions. Not a single fudgeType or HiddenTypeXXX! The only problem is it currently doesn't work; there is a bug somewhere. --- src/Platform.elm | 2 + src/Platform/RawScheduler.elm | 210 ++++++++++++++-------------------- 2 files changed, 90 insertions(+), 122 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 7ca0f667..c7ed4288 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -39,6 +39,8 @@ import String exposing (String) import Char exposing (Char) import Tuple +import Debug + import Platform.Cmd as Cmd exposing ( Cmd ) import Platform.Sub as Sub exposing ( Sub ) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index a317c904..64394478 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -41,11 +41,11 @@ import Maybe exposing (Maybe(..)) import Elm.Kernel.Basics import Elm.Kernel.Scheduler import List exposing ((::)) +import Debug type Task val = Value val - | AndThen (HiddenValA -> Task val) (Task val) - | AsyncAction (DoneCallback val -> TryAbortAction) TryAbortAction + | AsyncAction (DoneCallback val -> TryAbortAction) | SyncAction (() -> Task val) @@ -56,10 +56,15 @@ type alias DoneCallback val = type alias TryAbortAction = () -> () + +type ProcessRoot state + = Ready (Task state) + | Running TryAbortAction + + type ProcessState msg state = ProcessState - { root : Task state - , stack : List (HiddenValB -> Task HiddenValC) + { root : ProcessRoot state , mailbox : List msg , receiver : Maybe (msg -> state -> Task state) } @@ -71,26 +76,12 @@ type ProcessId msg } -type HiddenValA - = HiddenValA Never - - -type HiddenValB - = HiddenValB Never - - -type HiddenValC - = HiddenValC Never - - type UniqueId = UniqueId Never async : (DoneCallback val -> TryAbortAction) -> Task val -async callback = +async = AsyncAction - callback - identity sync : (() -> Task val) -> Task val @@ -100,9 +91,19 @@ sync = andThen : (a -> Task b) -> Task a -> Task b andThen func task = - AndThen - (Elm.Kernel.Basics.fudgeType func) - (Elm.Kernel.Basics.fudgeType task) + case task of + Value val -> + func val + + SyncAction thunk -> + SyncAction (\() -> andThen func (thunk ())) + + AsyncAction doEffect -> + AsyncAction + (\doneCallback -> + doEffect + (\newTask -> doneCallback (andThen func newTask)) + ) {-| NON PURE! @@ -118,9 +119,8 @@ rawSpawn task = } ) (ProcessState - { root = (Elm.Kernel.Basics.fudgeType task) + { root = Ready task , mailbox = [] - , stack = [] , receiver = Nothing } ) @@ -220,10 +220,10 @@ kill processId = (\doneCallback -> let _ = case root of - AsyncAction _ killer -> + Running killer -> killer () - _ -> + Ready _ -> () in let @@ -270,105 +270,71 @@ the process it is passed as an argument stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state stepper processId (ProcessState process) = let - (ProcessState steppedProcess, maybeFinalValue) = - case {- Debug.log "root" -} process.root of - Value val -> - let - moveStackFowards stack = - case stack of - callback :: rest -> - ( stepper - processId - ( ProcessState - { process - | root = (Elm.Kernel.Basics.fudgeType (callback (Elm.Kernel.Basics.fudgeType val))) - , stack = rest - } - ) - , Nothing - ) + _ = Debug.log "id" processId + in - _ -> - (ProcessState process, Just val) - - in - moveStackFowards process.stack - - AsyncAction doEffect killer -> - let - newProcess = - { process - | root = {- Debug.log "killableRoot" -} killableRoot - } - - killableRoot = - AsyncAction - (cannotBeStepped processId) - (doEffect (\newRoot -> - let - _ = - (updateProcessState - (\(ProcessState p) -> - ProcessState - { p | root = {- Debug.log "newRoot" -} newRoot } - ) - processId - ) - in - let - -- todo: avoid enqueue here - _ = - enqueue processId - in - () - )) - in - (ProcessState newProcess, Nothing) - - SyncAction doEffect-> - let - newProcess = - { process - | root = {- Debug.log "syncRoot" -} (doEffect ()) - } - in - ( stepper - processId - (ProcessState newProcess) - , Nothing + case Debug.log "process" process.root of + Running _ -> + (ProcessState process) + + Ready (Value val) -> + case Debug.log "receive" (process.mailbox, process.receiver) of + (first :: rest, Just receiver) -> + stepper + processId + (ProcessState + { process + | root = {- Debug.log "receiverRoot" -} Ready (receiver first val) + , mailbox = rest + } ) - AndThen callback task -> - ( stepper - processId - (ProcessState - { process - | root = {- Debug.log "andThenRoot" -} task - , stack = (Elm.Kernel.Basics.fudgeType callback) :: process.stack - } - ) - , Nothing - ) - in - case (steppedProcess.mailbox, maybeFinalValue, steppedProcess.receiver) of - (first :: rest, Just val, Just receiver) -> - stepper - processId - (ProcessState - { process - | root = {- Debug.log "receiverRoot" -} (receiver first val) - , mailbox = rest - } - ) - - ([], _, _) -> - ProcessState process - - (_, Nothing, _) -> - ProcessState process - - (_, _, Nothing) -> - ProcessState process + ([], _) -> + ProcessState process + + (_, Nothing) -> + ProcessState process + + Ready (AsyncAction doEffect) -> + let + newProcess = + { process + | root = {- Debug.log "killableRoot" -} killableRoot + } + + killableRoot = + Running + (doEffect (\newRoot -> + let + _ = + (updateProcessState + (\(ProcessState p) -> + ProcessState + { p | root = {- Debug.log "newRoot" -} Ready newRoot } + ) + processId + ) + in + let + -- todo: avoid enqueue here + _ = + enqueue processId + in + () + )) + in + ProcessState newProcess + + Ready (SyncAction doEffect) -> + let + newProcess = + { process + | root = {- Debug.log "syncRoot" -} Ready (doEffect ()) + } + in + stepper + processId + (ProcessState newProcess) -- Kernel function redefinitons -- From 55448ae2daa09984f72317a07acb63c0aa701279 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 15:01:28 +0000 Subject: [PATCH 030/170] update scripts --- custom-core.sh | 36 +++++++++++++++++++----------------- init-elm-home.sh | 17 +++++++++++++++++ refresh.sh | 7 ------- 3 files changed, 36 insertions(+), 24 deletions(-) create mode 100755 init-elm-home.sh delete mode 100755 refresh.sh diff --git a/custom-core.sh b/custom-core.sh index 023d4b78..69eafd9f 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -12,31 +12,33 @@ printf "Sucess if ends with DONE: " ELM="${ELM:-elm}" ELM_VERSION="$($ELM --version)" -CORE_GIT_DIR=$(realpath $1) - -rm -rf "$ELM_HOME/$ELM_VERSION/packages/elm/core/" cd $1 -if [[ ! -d elm-minimal ]]; then - git clone https://github.com/harrysarson/elm-minimal > /dev/null -fi +CORE_VERSIONS_DIR="$ELM_HOME/$ELM_VERSION/packages/elm/core" -cd elm-minimal -git reset master --hard > /dev/null -rm -rf elm-stuff +if [[ -d "$CORE_VERSIONS_DIR" ]]; then + CORE_VERSION_COUNT=$(ls "$CORE_VERSIONS_DIR" | wc -l) + CORE_VERSION=$(ls "$CORE_VERSIONS_DIR") + CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" -$ELM make src/Main.elm --output /dev/null > /dev/null || true; -cd - > /dev/null + if [ CORE_VERSION_COUNT == 1 ] || [[ -f $CORE_PACKAGE_DIR/custom ]]; then + printf "REFRESH " + else + printf "INIT " + ./init-elm-home.sh > /dev/null + fi +else + printf "INIT " + ./init-elm-home.sh > /dev/null +fi +CORE_VERSION=$(ls $CORE_VERSIONS_DIR) +CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" -CORE_VERSION="$(ls $ELM_HOME/$ELM_VERSION/packages/elm/core/)" -CORE_PACKAGE_DIR="$ELM_HOME/$ELM_VERSION/packages/elm/core/$CORE_VERSION" rm -rf "$CORE_PACKAGE_DIR" > /dev/null -ln -sv "$CORE_GIT_DIR" "$CORE_PACKAGE_DIR" > /dev/null - -./refresh.sh "$CORE_GIT_DIR" +cp -r . "$CORE_PACKAGE_DIR" > /dev/null +touch "$CORE_PACKAGE_DIR/custom" printf "DONE\n" - diff --git a/init-elm-home.sh b/init-elm-home.sh new file mode 100755 index 00000000..ca381539 --- /dev/null +++ b/init-elm-home.sh @@ -0,0 +1,17 @@ +#! /usr/bin/env bash + +set -o errexit; +set -o nounset; + +ELM="${ELM:-elm}" +ELM_VERSION="$($ELM --version)" +CORE_GIT_DIR=$(realpath .) + + +rm -rf "$ELM_HOME" +cd $(mktemp -d) + +git clone -q https://github.com/harrysarson/elm-minimal +cd elm-minimal +$ELM make src/Main.elm --output /dev/null || true; + diff --git a/refresh.sh b/refresh.sh deleted file mode 100755 index 9e89bc08..00000000 --- a/refresh.sh +++ /dev/null @@ -1,7 +0,0 @@ -#! /usr/bin/env bash - -set -o errexit; -set -o nounset; - -rm -vf "$1"/*.dat "$1"/doc*.json > /dev/null - From f80f14d48dfaa90215897cbafe9208aeb60a7b21 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 15:05:03 +0000 Subject: [PATCH 031/170] ctidying and misc improvements During this commit I was trying to track down a nasty bug in my runtime. The bug is caused by a call to updateProcessState from within the function passed to updateProcessState. The result of the inner call to updateProcessState was then overwritten by the result of the out call to updateProcessState. Nasty! --- src/Elm/Kernel/Debug.js | 5 ++- src/Elm/Kernel/Scheduler.js | 14 +++---- src/Platform/RawScheduler.elm | 70 ++++++++++++++++------------------- 3 files changed, 42 insertions(+), 47 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index d809c1b7..07f904d9 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -319,8 +319,11 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) case 'cannotBeStepped': throw new Error(`Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!`); + + case 'reentrantProcUpdate': + throw new Error(`Bug in elm runtime: Elm.Kernel.Scheduler.updateProcessState was called from within the update function!`); } - throw new Error(`Unknown bug in elm runtime id: ${identifier}!`); + throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); } } throw new Error(`Unknown error id: ${identifier}!`); diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 97bae41c..f5812b7e 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -37,7 +37,6 @@ function _Scheduler_getGuid() { } function _Scheduler_getProcessState(id) { - // console.log("get", id); const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { @@ -49,13 +48,18 @@ function _Scheduler_getProcessState(id) { var _Scheduler_updateProcessState = F2((func, id) => { const procState = _Scheduler_processes.get(id); - // console.log("update", id, procState); /**__DEBUG/ if (procState === undefined) { __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.__$id); } //*/ - _Scheduler_processes.set(id, func(procState)); + const updatedState = func(procState); + /**__DEBUG/ + if (procState !== _Scheduler_processes.get(id)) { + __Debug_crash(12, 'reentrantProcUpdate', id && id.a && id.a.__$id); + } + //*/ + _Scheduler_processes.set(id, updatedState); return procState; }); @@ -102,7 +106,3 @@ var _Scheduler_delay = F3(function (time, value, callback) return function(x) { clearTimeout(id); return x; }; }); - -const _Scheduler_cannotBeStepped = F2((procId, _1) => { - __Debug_crash(12, 'cannotBeStepped', procId && procId.a && procId.a.__$id) -}); diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 64394478..70da4737 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -159,7 +159,7 @@ rawSend processId msg = updateProcessState (\(ProcessState procState) -> ProcessState - { procState | mailbox = procState.mailbox ++ [msg]} + { procState | mailbox = procState.mailbox ++ [msg]} ) processId in @@ -189,17 +189,27 @@ send processId msg = -} spawn : Task a -> Task (ProcessId never) spawn task = - let - thunk : DoneCallback (ProcessId never) -> TryAbortAction - thunk doneCallback = - let - _ = - doneCallback (Value (rawSpawn task)) - in - (\() -> ()) - in - async - thunk + if False then + let + thunk : () -> Task (ProcessId never) + thunk doneCallback = + Value (rawSpawn task) + in + sync + thunk + else + let + thunk : DoneCallback (ProcessId never) -> TryAbortAction + thunk doneCallback = + let + _ = + doneCallback (Value (rawSpawn task)) + in + (\() -> ()) + in + async + thunk + {-| Create a task that sleeps for `time` milliseconds -} @@ -254,10 +264,6 @@ enqueue id = ) id --- Helper types -- - - - -- Helper functions -- @@ -269,22 +275,18 @@ the process it is passed as an argument -} stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state stepper processId (ProcessState process) = - let - _ = Debug.log "id" processId - in - - case Debug.log "process" process.root of + case process.root of Running _ -> (ProcessState process) Ready (Value val) -> - case Debug.log "receive" (process.mailbox, process.receiver) of + case (process.mailbox, process.receiver) of (first :: rest, Just receiver) -> stepper processId (ProcessState { process - | root = {- Debug.log "receiverRoot" -} Ready (receiver first val) + | root = Ready (receiver first val) , mailbox = rest } ) @@ -296,21 +298,16 @@ stepper processId (ProcessState process) = ProcessState process Ready (AsyncAction doEffect) -> - let - newProcess = + ProcessState { process - | root = {- Debug.log "killableRoot" -} killableRoot - } - - killableRoot = - Running + | root = Running (doEffect (\newRoot -> let _ = (updateProcessState (\(ProcessState p) -> ProcessState - { p | root = {- Debug.log "newRoot" -} Ready newRoot } + { p | root = Ready newRoot } ) processId ) @@ -318,18 +315,17 @@ stepper processId (ProcessState process) = let -- todo: avoid enqueue here _ = - enqueue processId + enqueue processId in () )) - in - ProcessState newProcess + } Ready (SyncAction doEffect) -> let newProcess = { process - | root = {- Debug.log "syncRoot" -} Ready (doEffect ()) + | root = Ready (doEffect ()) } in stepper @@ -363,7 +359,3 @@ enqueueWithStepper = delay : Float -> Task val -> DoneCallback val -> TryAbortAction delay = Elm.Kernel.Scheduler.delay - -cannotBeStepped : ProcessId msg -> DoneCallback state -> TryAbortAction -cannotBeStepped = - Elm.Kernel.Scheduler.cannotBeStepped From 6e899f0a3e0825ff5567f8c8e6fd7ebdfded1192 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 19:52:08 +0000 Subject: [PATCH 032/170] tests pass! --- src/Elm/Kernel/Scheduler.js | 7 ++++ src/Platform.elm | 6 ++-- src/Platform/RawScheduler.elm | 65 +++++++++++++++++------------------ src/Platform/Scheduler.elm | 2 +- 4 files changed, 43 insertions(+), 37 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index f5812b7e..947975ff 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -2,6 +2,7 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding) import Elm.Kernel.Debug exposing (crash) +import Elm.Kernel.Utils exposing (Tuple0) */ // COMPATIBILITY @@ -106,3 +107,9 @@ var _Scheduler_delay = F3(function (time, value, callback) return function(x) { clearTimeout(id); return x; }; }); + + +const _Scheduler_runOnNextTick = F2((callback, val) => { + Promise.resolve(val).then(callback); + return _Utils_Tuple0; +}); diff --git a/src/Platform.elm b/src/Platform.elm index c7ed4288..19ee6c58 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -161,7 +161,7 @@ be handled by the overall `update` function, just like events from `Html`. sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = Task - (RawScheduler.sync + (RawScheduler.SyncAction (\() -> let _ = @@ -203,7 +203,7 @@ setupOutgoingPort sendToApp2 outgoingPortSend = execInOrder cmdList = case cmdList of first :: rest -> - RawScheduler.sync (\() -> + RawScheduler.SyncAction (\() -> let _ = outgoingPortSend first in @@ -239,7 +239,7 @@ setupIncomingPort sendToApp2 updateSubs = onEffects _ _ subList () = Task - (RawScheduler.sync + (RawScheduler.SyncAction (\() -> let _ = updateSubs subList diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 70da4737..78839bf1 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -79,16 +79,6 @@ type ProcessId msg type UniqueId = UniqueId Never -async : (DoneCallback val -> TryAbortAction) -> Task val -async = - AsyncAction - - -sync : (() -> Task val) -> Task val -sync = - SyncAction - - andThen : (a -> Task b) -> Task a -> Task b andThen func task = case task of @@ -171,7 +161,7 @@ rawSend processId msg = -} send : ProcessId msg -> msg -> Task () send processId msg = - async + AsyncAction (\doneCallback -> let _ = @@ -195,7 +185,7 @@ spawn task = thunk doneCallback = Value (rawSpawn task) in - sync + SyncAction thunk else let @@ -207,7 +197,7 @@ spawn task = in (\() -> ()) in - async + AsyncAction thunk @@ -215,7 +205,7 @@ spawn task = -} sleep : Float -> Task () sleep time = - async (delay time (Value ())) + AsyncAction (delay time (Value ())) {-| Create a task kills a process. @@ -226,7 +216,7 @@ kill processId = (ProcessState { root }) = getProcessState processId in - async + AsyncAction (\doneCallback -> let _ = case root of @@ -301,24 +291,28 @@ stepper processId (ProcessState process) = ProcessState { process | root = Running - (doEffect (\newRoot -> - let - _ = - (updateProcessState - (\(ProcessState p) -> - ProcessState - { p | root = Ready newRoot } - ) - processId - ) - in - let - -- todo: avoid enqueue here - _ = - enqueue processId - in - () - )) + (doEffect ( + runOnNextTick + (\newRoot -> + let + _ = + + (updateProcessState + (\(ProcessState p) -> + ProcessState + { p | root = Ready newRoot } + ) + processId + ) + in + let + -- todo: avoid enqueue here + _ = + enqueue processId + in + () + ) + )) } Ready (SyncAction doEffect) -> @@ -359,3 +353,8 @@ enqueueWithStepper = delay : Float -> Task val -> DoneCallback val -> TryAbortAction delay = Elm.Kernel.Scheduler.delay + + +runOnNextTick : (a -> ()) -> a -> () +runOnNextTick = + Elm.Kernel.Scheduler.runOnNextTick diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index e89723c5..7823a9e6 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -39,7 +39,7 @@ fail e = binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok binding callback = Platform.Task - (RawScheduler.async + (RawScheduler.AsyncAction (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) ) From c8c1d86e87d7a948bfac955ac5f297c30ead5543 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 20:08:15 +0000 Subject: [PATCH 033/170] remove some uses of fudgeType --- src/Elm/Kernel/Platform.js | 8 ++++---- src/Platform.elm | 12 ++++++++---- src/Platform/Bag.elm | 3 --- src/Platform/Cmd.elm | 22 +++------------------- src/Platform/Sub.elm | 21 ++------------------- 5 files changed, 17 insertions(+), 49 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index f83c108d..ce94c380 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -121,17 +121,17 @@ const _Platform_cmdOnlySubMap = F2(function(_1, _2) { }); -const _Platform_getCmdMapper = F2(function(portCmdMapper, home) { +const _Platform_getCmdMapper = home => { if (_Platform_outgoingPorts.hasOwnProperty(home)) { - return portCmdMapper; + return F2((_tagger, value) => value); } return _Platform_effectManagers[home].__cmdMapper; -}); +}; const _Platform_getSubMapper = F2(function(portSubMapper, home) { if (_Platform_incomingPorts.hasOwnProperty(home)) { - return portSubMapper; + return F2((tagger, finalTagger) => value => tagger(finalTagger(value))); } return _Platform_effectManagers[home].__subMapper; }); diff --git a/src/Platform.elm b/src/Platform.elm index 19ee6c58..20ba6d50 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -220,7 +220,9 @@ setupOutgoingPort sendToApp2 outgoingPortSend = -> Task Never () onEffects _ cmdList _ () = let - typedCmdList = Elm.Kernel.Basics.fudgeType cmdList + typedCmdList : List EncodeValue + typedCmdList = + Elm.Kernel.Basics.fudgeType cmdList in Task (execInOrder typedCmdList) @@ -295,6 +297,8 @@ dispatchEffects cmd sub = Maybe.withDefault ([], []) (Dict.get (effectManagerNameToString key) effectsDict) + + _ = RawScheduler.rawSend selfProcess @@ -460,10 +464,10 @@ type HiddenTypeB = HiddenTypeB Never -type HiddenMyCmd msg = HiddenMyCmd Never +type HiddenMyCmd msg = HiddenMyCmd (Bag.LeafType msg) -type HiddenMySub msg = HiddenMySub Never +type HiddenMySub msg = HiddenMySub (Bag.LeafType msg) type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg @@ -500,7 +504,7 @@ type alias InitFunctions model appMsg = , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () } --- -- kernel -- +-- kernel -- initialize : Decoder flags -> diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index 9c335012..80cd7ca0 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -3,9 +3,6 @@ module Platform.Bag exposing , EffectManagerName ) -import Basics exposing (Never) -import String exposing (String) - type LeafType msg = LeafType Kernel diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 9db4a3a3..ee816adb 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -103,25 +103,9 @@ map fn (Data data) = |> Data --- HELPERS -- - - -type HiddenA = HiddenA Never - - -type HiddenB = HiddenB Never - - -outgoingPortCmdMap : (a -> b) -> Bag.LeafType a -> Bag.LeafType msg -outgoingPortCmdMap _ value = - fudgeLeafType value +-- Kernel function redefinitons -- getCmdMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg -getCmdMapper home = - Elm.Kernel.Platform.getCmdMapper outgoingPortCmdMap home - - -fudgeLeafType : Bag.LeafType a -> Bag.LeafType b -fudgeLeafType = - Elm.Kernel.Basics.fudgeType +getCmdMapper = + Elm.Kernel.Platform.getCmdMapper diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index b24f1c24..49097c64 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -80,8 +80,6 @@ batch = >> Data - - -- FANCY STUFF @@ -103,26 +101,11 @@ map fn (Data data) = ) |> Data --- HELPERS -- - -type HiddenA = HiddenA Never +-- Kernel function redefinitons -- -type HiddenB = HiddenB Never - -outgoingPortSubMap : (a -> b) -> (data -> a) -> (data -> b) -outgoingPortSubMap tagger finalTagger = - (\val -> tagger (finalTagger val)) - -fudgedOutgoingPortSubMap : (a -> b) -> Bag.LeafType a -> Bag.LeafType b -fudgedOutgoingPortSubMap tagger finalTagger = - Elm.Kernel.Basics.fudgeType outgoingPortSubMap getSubMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg getSubMapper home = - Elm.Kernel.Platform.getSubMapper fudgedOutgoingPortSubMap home - + Elm.Kernel.Platform.getSubMapper home -fudgeLeafType : Bag.LeafType a -> Bag.LeafType b -fudgeLeafType = - Elm.Kernel.Basics.fudgeType From 992c1dbf5420cbfaca12217c3c9143c1a8c64018 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 20:16:38 +0000 Subject: [PATCH 034/170] drop dead code and minimise number of fudges --- src/Platform.elm | 51 ++++++++++++------------------------------------ 1 file changed, 12 insertions(+), 39 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 20ba6d50..3d5fdce9 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -112,7 +112,7 @@ worker impl = { stepperBuilder = \ _ _ -> (\ _ _ -> ()) , setupOutgoingPort = setupOutgoingPort , setupIncomingPort = setupIncomingPort - , setupEffects = hiddenSetupEffects + , setupEffects = setupEffects , dispatchEffects = dispatchEffects } ) @@ -252,24 +252,17 @@ setupIncomingPort sendToApp2 updateSubs = onSend : msg -> List (HiddenMySub msg) -> () onSend value subs = - let - typedSubs : List (msg -> msg) - typedSubs = - Elm.Kernel.Basics.fudgeType subs - in - List.foldr - (\sub () -> sendToApp2 (sub value) AsyncUpdate) + (\sub () -> + let + typedSub : msg -> msg + typedSub = + Elm.Kernel.Basics.fudgeType sub + in + sendToApp2 (typedSub value) AsyncUpdate + ) () - typedSubs - - typedSubMap : (msg1 -> msg2) -> (a -> msg1) -> (a -> msg2) - typedSubMap tagger finalTagger = - (\val -> tagger (finalTagger val)) - - subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB - subMap tagger finalTagger = - Elm.Kernel.Basics.fudgeType typedSubMap + subs in ( instantiateEffectManager sendToApp2 init onEffects onSelfMsg , onSend @@ -324,14 +317,10 @@ gatherSubs (Sub.Data subs) effectsDict = gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherHelper isCmd home value effectsDict = - let - effect = - (Elm.Kernel.Basics.fudgeType value) - in +gatherHelper isCmd home effectData effectsDict = Dict.insert (effectManagerNameToString home) - (createEffect isCmd effect (Dict.get (effectManagerNameToString home) effectsDict)) + (createEffect isCmd effectData (Dict.get (effectManagerNameToString home) effectsDict)) effectsDict @@ -354,11 +343,6 @@ setupEffects sendToAppP init onEffects onSelfMsg = instantiateEffectManager sendToAppP init onEffects onSelfMsg -hiddenSetupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg -hiddenSetupEffects = - Elm.Kernel.Basics.fudgeType setupEffects - - instantiateEffectManager : SendToApp appMsg -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) @@ -434,17 +418,6 @@ type ReceivedData appMsg selfMsg | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) -type EffectManager state appMsg selfMsg - = EffectManager - { onSelfMsg : Router appMsg selfMsg -> selfMsg -> state -> Task Never state - , init : Task Never state - , onEffects: Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state - , cmdMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMyCmd HiddenTypeA -> HiddenMyCmd HiddenTypeB - , subMap : (HiddenTypeA -> HiddenTypeB) -> HiddenMySub HiddenTypeA -> HiddenMySub HiddenTypeB - , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) - } - - type OutgoingPort = OutgoingPort { subscribe: (EncodeValue -> ()) From b799bd44d369b75bc5dbfcad237433893a48b285 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 22:04:23 +0000 Subject: [PATCH 035/170] implement process functions --- src/Process.elm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Process.elm b/src/Process.elm index 8f3e46a8..a71f833a 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -46,7 +46,7 @@ longer. That’s kind of what Elm is all about. import Basics exposing (..) import Platform --- import Platform.Scheduler as Scheduler +import Platform.Scheduler as Scheduler import Task exposing (Task) import Debug @@ -81,7 +81,7 @@ come in a later release! -} spawn : Task x a -> Task y Id spawn = - Debug.todo "Scheduler.spawn" + Scheduler.spawn {-| Block progress on the current process for the given number of milliseconds. @@ -92,7 +92,7 @@ delay work until later. -} sleep : Float -> Task x () sleep = - Debug.todo " Scheduler.sleep" + Scheduler.sleep {-| Sometimes you `spawn` a process, but later decide it would be a waste to @@ -101,5 +101,5 @@ to bail on whatever task it is running. So if there is an HTTP request in flight, it will also abort the request. -} kill : Id -> Task x () -kill = - Debug.todo "Scheduler.kill proc" +kill (Platform.ProcessId processId) = + Scheduler.kill processId From 195c9b20604ff25d19501db211da5415e2700522 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 20 Dec 2019 23:22:45 +0000 Subject: [PATCH 036/170] tidy some more knarly bits of the runtime --- src/Elm/Kernel/Debug.js | 7 +- src/Elm/Kernel/Platform.js | 184 ++++++++++++++-------------------- src/Platform.elm | 36 ++++--- src/Platform/RawScheduler.elm | 53 +++------- src/Platform/Scheduler.elm | 6 +- 5 files changed, 117 insertions(+), 169 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 07f904d9..06c62d67 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -306,10 +306,10 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) { switch (fact1) { case 'subMap': - throw new Error('Bug in elm runtime: attempting to subMap command only effect module.'); + throw new Error('Bug in elm runtime: attempting to subMap an effect from a command only effect module.'); case 'cmdMap': - throw new Error('Bug in elm runtime: attempting to cmdMap subscription only effect module.'); + throw new Error('Bug in elm runtime: attempting to cmdMap an effect from a subscription only effect module.'); case 'procIdAlreadyRegistered': throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); @@ -322,6 +322,9 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) case 'reentrantProcUpdate': throw new Error(`Bug in elm runtime: Elm.Kernel.Scheduler.updateProcessState was called from within the update function!`); + + case 'earlyMsg': + throw new Error(`Bug in elm runtime: an event manager received a message before it was ready.`); } throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index ce94c380..8c39edc6 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -2,7 +2,7 @@ import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) -import Elm.Kernel.List exposing (Nil) +import Elm.Kernel.List exposing (Cons, Nil) import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) @@ -14,9 +14,6 @@ var _Platform_outgoingPorts = {}; var _Platform_incomingPorts = {}; var _Platform_effectManagers = {}; -const _Platform_cmdMappers = {}; -const _Platform_subMappers = {}; - // INITIALIZE A PROGRAM const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { @@ -78,7 +75,6 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { }); - // TRACK PRELOADS // // This is used by code in elm/browser and elm/http @@ -95,126 +91,69 @@ function _Platform_registerPreload(url) } - // EFFECT MANAGERS -function _Platform_effectManagerNameToString(name) { - // console.log("effect to string", name); - return name; -} - -const _Platform_subOnlyCmdMap = F2(function(_1, _2) { - /**__DEBUG/ - if (procState === undefined) { - __Debug_crash(12, 'cmdMap'); - } - //*/ -}); - -const _Platform_cmdOnlySubMap = F2(function(_1, _2) { - /**__DEBUG/ - if (procState === undefined) { - __Debug_crash(12, 'subMap'); - } - //*/ -}); - - -const _Platform_getCmdMapper = home => { - if (_Platform_outgoingPorts.hasOwnProperty(home)) { - return F2((_tagger, value) => value); - } - return _Platform_effectManagers[home].__cmdMapper; -}; - - -const _Platform_getSubMapper = F2(function(portSubMapper, home) { - if (_Platform_incomingPorts.hasOwnProperty(home)) { - return F2((tagger, finalTagger) => value => tagger(finalTagger(value))); - } - return _Platform_effectManagers[home].__subMapper; -}); - - -// Called by compiler generated js when creating event mangers +/* Called by compiler generated js when creating event mangers. + * + * This function will **always** be call right after page load. + */ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { - // TODO(harry) confirm this is valid - let fullOnEffects, fullCmdMap, fullSubMap; + const make_setup = fullOnEffects => (setup, sendToApp) => { + return A4(setup, sendToApp, init, fullOnEffects, onSelfMsg) + } if (cmdMap === undefined) { // Subscription only effect module - fullOnEffects = F4(function(router, cmds, subs, state) { - return A3(onEffects, router, subs, state); - }); - fullCmdMap = _Platform_subOnlyCmdMap; - _Platform = subMap; + return { + __cmdMapper: F2((_1, _2) => __Debug_crash(12, 'cmdMap')), + __subMapper: subMap, + __setup: make_setup(F4(function(router, _cmds, subs, state) { + return A3(onEffects, router, subs, state); + })), + }; } else if (subMap === undefined) { // Command only effect module - fullOnEffects = F4(function(router, cmds, subs, state) { - return A3(onEffects, router, cmds, state); - }); - fullCmdMap = cmdMap; - fullSubMap = _Platform_cmdOnlySubMap; + return { + __cmdMapper: cmdMap, + __subMapper: F2((_1, _2) => __Debug_crash(12, 'subMap')), + __setup: make_setup(F4(function(router, cmds, _subs, state) { + return A3(onEffects, router, cmds, state); + })), + }; } else { - fullOnEffects = onEffects; - fullCmdMap = cmdMap; - fullSubMap = subMap; + // Command **and** subscription event manager + return { + __cmdMapper: cmdMap, + __subMapper: subMap, + __setup: make_setup(onEffects), + }; } - - // Command **and** subscription event manager - return { - __cmdMapper: fullCmdMap, - __subMapper: fullSubMap, - __setup: function(setup, sendToApp) { - return A4(setup, sendToApp, init, fullOnEffects, onSelfMsg) - } - }; } // BAGS - /* Called by compiler generated js for event managers for the * `command` or `subscription` function within an event manager */ -function _Platform_leaf(home) -{ - return function(value) - { - /**__DEBUG/ - return { - $: 'Data', - a: { - $: '::', - a: { - __$home: home, - __$value: value - }, - b: { - $: '[]' - } - } - }; - //*/ - - /**__PROD/ - return { - $: , - a: { - $: 1, - a: { - __$home: home, - __$value: value - }, - b: { - $: 0 - } - } - }; - //*/ +const _Platform_leaf = home => value => { + const list = __List_Cons({ + __$home: home, + __$value: value + }, __List_Nil); + let tag; + /**__DEBUG/ + tag = 'Data' + /**/ + /**__PROD/ + tag = 0 + * + /**/ + return { + $: tag, + a: list }; -} +}; // PORTS @@ -242,8 +181,8 @@ function _Platform_outgoingPort(name, converter) function unsubscribe(callback) { - // copy subs into a new array in case unsubscribe is called within a - // subscribed callback + // copy subs into a new array in case unsubscribe is called within + // a subscribed callback subs = subs.slice(); var index = subs.indexOf(callback); if (index >= 0) @@ -253,7 +192,7 @@ function _Platform_outgoingPort(name, converter) } const outgoingPortSend = payload => { - var value = __Json_unwrap(converter(payload)); + const value = __Json_unwrap(converter(payload)); for (const sub of subs) { sub(value); @@ -315,6 +254,33 @@ function _Platform_incomingPort(name, converter) } +// Functions exported to elm + + +const _Platform_effectManagerNameToString = name => name; + + +const _Platform_getCmdMapper = home => { + if (_Platform_outgoingPorts.hasOwnProperty(home)) { + return F2((_tagger, value) => value); + } + return _Platform_effectManagers[home].__cmdMapper; +}; + + +const _Platform_getSubMapper = home => { + if (_Platform_incomingPorts.hasOwnProperty(home)) { + return F2((tagger, finalTagger) => value => tagger(finalTagger(value))); + } + return _Platform_effectManagers[home].__subMapper; +}; + + +const _Platform_crashOnEarlyMessage = F2((_1, _2) => + __Debug_crash(12, 'earlyMsg') +); + + // EXPORT ELM MODULES // diff --git a/src/Platform.elm b/src/Platform.elm index 3d5fdce9..8485e46d 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -149,11 +149,12 @@ type ProcessId = {-| An effect manager has access to a “router” that routes messages between the main app and your individual effect manager. -} -type Router appMsg selfMsg = - Router - { sendToApp: appMsg -> () - , selfProcess: RawScheduler.ProcessId selfMsg - } +type Router appMsg selfMsg + = Router + { sendToApp: appMsg -> () + , selfProcess: RawScheduler.ProcessId selfMsg + } + {-| Send the router a message for the main loop of your app. This message will be handled by the overall `update` function, just like events from `Html`. @@ -163,11 +164,7 @@ sendToApp (Router router) msg = Task (RawScheduler.SyncAction (\() -> - let - _ = - router.sendToApp msg - in - RawScheduler.Value (Ok ()) + RawScheduler.Value (Ok (router.sendToApp msg)) ) ) @@ -190,6 +187,9 @@ sendToSelf (Router router) msg = ) +-- HELPERS -- + + setupOutgoingPort : SendToApp msg -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData msg Never) setupOutgoingPort sendToApp2 outgoingPortSend = let @@ -269,9 +269,6 @@ setupIncomingPort sendToApp2 updateSubs = ) - --- -- HELPERS -- - dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName @@ -373,11 +370,12 @@ instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = selfProcess = - RawScheduler.rawSpawn ( - RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) - ) + RawScheduler.rawSpawn + Elm.Kernel.Platform.crashOnEarlyMessage + (RawScheduler.andThen + (\() -> init) + (RawScheduler.sleep 0) + ) router = @@ -386,7 +384,7 @@ instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = , selfProcess = selfProcess } in - RawScheduler.rawSetReceiver selfProcess receiver + RawScheduler.rawSetReceiver receiver selfProcess type alias SendToApp msg = diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 78839bf1..40893754 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -66,7 +66,7 @@ type ProcessState msg state = ProcessState { root : ProcessRoot state , mailbox : List msg - , receiver : Maybe (msg -> state -> Task state) + , receiver : msg -> state -> Task state } @@ -100,8 +100,8 @@ andThen func task = Will create, **enqueue** and return a new process. -} -rawSpawn : Task a -> ProcessId never -rawSpawn task = +rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg +rawSpawn receiver task = enqueue (registerNewProcess (ProcessId @@ -111,7 +111,7 @@ rawSpawn task = (ProcessState { root = Ready task , mailbox = [] - , receiver = Nothing + , receiver = receiver } ) ) @@ -122,14 +122,14 @@ rawSpawn task = Will modify an existing process, **enqueue** and return it. -} -rawSetReceiver : ProcessId msg -> (msg -> a -> Task a) -> ProcessId msg -rawSetReceiver processId receiver = +rawSetReceiver : (msg -> a -> Task a) -> ProcessId msg -> ProcessId msg +rawSetReceiver receiver processId = let _ = updateProcessState (\(ProcessState state) -> ProcessState - { state | receiver = Just receiver } + { state | receiver = receiver } ) processId in @@ -142,7 +142,7 @@ Send a message to a process and **enqueue** that process so that it can perform actions based on the message. -} -rawSend : ProcessId msg -> msg-> ProcessId msg +rawSend : ProcessId msg -> msg -> ProcessId msg rawSend processId msg = let _ = @@ -177,28 +177,10 @@ send processId msg = {-| Create a task that spawns a processes. -} -spawn : Task a -> Task (ProcessId never) -spawn task = - if False then - let - thunk : () -> Task (ProcessId never) - thunk doneCallback = - Value (rawSpawn task) - in - SyncAction - thunk - else - let - thunk : DoneCallback (ProcessId never) -> TryAbortAction - thunk doneCallback = - let - _ = - doneCallback (Value (rawSpawn task)) - in - (\() -> ()) - in - AsyncAction - thunk +spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) +spawn receiver task = + SyncAction + (\() -> Value (rawSpawn receiver task)) {-| Create a task that sleeps for `time` milliseconds @@ -270,21 +252,18 @@ stepper processId (ProcessState process) = (ProcessState process) Ready (Value val) -> - case (process.mailbox, process.receiver) of - (first :: rest, Just receiver) -> + case process.mailbox of + first :: rest -> stepper processId (ProcessState { process - | root = Ready (receiver first val) + | root = Ready (process.receiver first val) , mailbox = rest } ) - ([], _) -> - ProcessState process - - (_, Nothing) -> + [] -> ProcessState process Ready (AsyncAction doEffect) -> diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 7823a9e6..c1e5295f 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -95,14 +95,16 @@ send proc msg = ) -{-| Create a task that spawns a processes. +{-| Create a task that, when run, will spawn a process. + +There is no way to send messages to a process spawned in this way. -} spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId spawn (Platform.Task task) = Platform.Task (RawScheduler.andThen (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) - (RawScheduler.spawn task) + (RawScheduler.spawn (\msg state -> never msg) task) ) From 89f2e5d7a094cd090189220205922c2f4554f45f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 20:16:16 +0000 Subject: [PATCH 037/170] only copy the required files running ./tests/run-tests.sh fills this directory with .dat and docs*.json files. Copying these files into $ELM_HOME confuses the compiler --- custom-core.sh | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/custom-core.sh b/custom-core.sh index 69eafd9f..d7556a78 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -38,7 +38,9 @@ CORE_VERSION=$(ls $CORE_VERSIONS_DIR) CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" rm -rf "$CORE_PACKAGE_DIR" > /dev/null -cp -r . "$CORE_PACKAGE_DIR" > /dev/null +mkdir "$CORE_PACKAGE_DIR" +cp -r src "$CORE_PACKAGE_DIR"/ > /dev/null +cp -r elm.json "$CORE_PACKAGE_DIR"/ > /dev/null touch "$CORE_PACKAGE_DIR/custom" printf "DONE\n" From f5bf64fb6311299fa94942ffe34023a773fe43dd Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 20:16:58 +0000 Subject: [PATCH 038/170] rework initialize --- src/Elm/Kernel/Platform.js | 76 +++++++++++++++++++++----------------- 1 file changed, 42 insertions(+), 34 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 8c39edc6..e1b799c5 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -20,58 +20,66 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a - const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); + const flagsResult = A2( + __Json_run, + flagDecoder, + __Json_wrap(args ? args['flags'] : undefined) + ); if (!__Result_isOk(flagsResult)) { __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); } - const sendToApp = F2((msg, viewMetadata) => { - const updateValue = A2(impl.__$update, msg, model); - model = updateValue.a - A2(stepper, model, viewMetadata); - - const dispatcher = A2(functions.__$dispatchEffects, updateValue.b, impl.__$subscriptions(model)); + const dispatch = (model, cmds) => { + const dispatcher = A2( + functions.__$dispatchEffects, + cmds, + impl.__$subscriptions(model) + ); for (const key in managers) { // console.log(managers[key]); A2(dispatcher, key, managers[key]); } + } + + const sendToApp = F2((msg, viewMetadata) => { + const updateValue = A2(impl.__$update, msg, model); + model = updateValue.a + A2(stepper, model, viewMetadata); + dispatch(model, updateValue.b); }); const managers = {}; const ports = {}; - - const initValue = impl.__$init(flagsResult.a); - let model = initValue.a; - const stepper = A2(functions.__$stepperBuilder, sendToApp, model); - - for (var key in _Platform_effectManagers) - { - const setup = _Platform_effectManagers[key].__setup; - managers[key] = setup(functions.__$setupEffects, sendToApp); + for (const [key, {__setup}] of Object.entries(_Platform_effectManagers)) { + managers[key] = __setup(functions.__$setupEffects, sendToApp); } - for (var key in _Platform_outgoingPorts) - { - const setup = _Platform_outgoingPorts[key](functions.__$setupOutgoingPort, sendToApp); - ports[key] = setup.ports; - managers[key] = setup.manager; + for (const [key, setup] of Object.entries(_Platform_outgoingPorts)) { + const {port, manager} = setup( + functions.__$setupOutgoingPort, + sendToApp + ); + ports[key] = port; + managers[key] = manager; } - for (var key in _Platform_incomingPorts) + for (const [key, setup] of Object.entries(_Platform_incomingPorts)) { - const setup = _Platform_incomingPorts[key](functions.__$setupIncomingPort, sendToApp); - ports[key] = setup.ports; - managers[key] = setup.manager; + const {port, manager} = setup( + functions.__$setupIncomingPort, + sendToApp + ); + ports[key] = port; + managers[key] = manager; } - // console.log('managers', managers); - const dispatcher = A2(functions.__$dispatchEffects, initValue.b, impl.__$subscriptions(model)); - for (const key in managers) { - // console.log(managers[key]); - A2(dispatcher, key, managers[key]); - } + const initValue = impl.__$init(flagsResult.a); + let model = initValue.a; + const stepper = A2(functions.__$stepperBuilder, sendToApp, model); + + dispatch(model, initValue.b); - return ports ? { ports: ports } : {}; + return ports ? { ports } : {}; }); @@ -208,7 +216,7 @@ function _Platform_outgoingPort(name, converter) ); return { - ports: { + port: { subscribe, unsubscribe, }, @@ -243,7 +251,7 @@ function _Platform_incomingPort(name, converter) } return { - ports: { + port: { send, }, manager: setupTuple.a, From 23ea65e55a366aae31d33ea7e8292eabb51e47fd Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 20:44:48 +0000 Subject: [PATCH 039/170] fix leaf for optimised builds --- src/Elm/Kernel/Platform.js | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index e1b799c5..5127241e 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -149,18 +149,15 @@ const _Platform_leaf = home => value => { __$home: home, __$value: value }, __List_Nil); - let tag; /**__DEBUG/ - tag = 'Data' - /**/ - /**__PROD/ - tag = 0 - * - /**/ return { $: tag, - a: list + a: list, }; + /**/ + /**__PROD/ + return list; + /**/ }; From 50369518e69d9f95b9e1ef97b986bf985040cb21 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 20:54:31 +0000 Subject: [PATCH 040/170] fix type in last commit --- src/Elm/Kernel/Platform.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 5127241e..cfdb8e6c 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -151,7 +151,7 @@ const _Platform_leaf = home => value => { }, __List_Nil); /**__DEBUG/ return { - $: tag, + $: 'Data', a: list, }; /**/ From 184804b105083b82ee5ad3d036ba15ca3b582375 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 20:46:26 +0000 Subject: [PATCH 041/170] Copy elm/core's enqueuing of effects. See: 704dcc08d4617d45c8b0fce7a68729335c880756 The approach here is almost identical, modulo adaptations to fit with the slightly different structure of the runtime. --- src/Elm/Kernel/Platform.js | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index cfdb8e6c..23b1d78e 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -14,6 +14,9 @@ var _Platform_outgoingPorts = {}; var _Platform_incomingPorts = {}; var _Platform_effectManagers = {}; +var _Platform_effectsQueue = []; +var _Platform_effectDispatchInProgress = false; + // INITIALIZE A PROGRAM const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { @@ -31,15 +34,31 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { } const dispatch = (model, cmds) => { - const dispatcher = A2( - functions.__$dispatchEffects, - cmds, - impl.__$subscriptions(model) - ); + _Platform_effectsQueue.push({ + __cmds: cmds, + __subs: impl.__$subscriptions(model), + }); + + if (_Platform_effectDispatchInProgress) { + return; + } - for (const key in managers) { - // console.log(managers[key]); - A2(dispatcher, key, managers[key]); + _Platform_effectDispatchInProgress = true; + while (true) { + const fx = _Platform_effectsQueue.shift(); + if (fx === undefined) { + _Platform_effectDispatchInProgress = false; + return; + } + const dispatcher = A2( + functions.__$dispatchEffects, + fx.__cmds, + fx.__subs, + ); + for (const key in managers) { + // console.log(managers[key]); + A2(dispatcher, key, managers[key]); + } } } From 1881317b1d9f63dc8aa00772c88be7049a7cc6aa Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 21:44:25 +0000 Subject: [PATCH 042/170] fix: return processId if scheduler already working --- src/Elm/Kernel/Scheduler.js | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 947975ff..e5ca4725 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -65,7 +65,6 @@ var _Scheduler_updateProcessState = F2((func, id) => { }); var _Scheduler_registerNewProcess = F2((procId, procState) => { - // console.log("registering", procId); /**__DEBUG/ if (procState === undefined) { __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); @@ -84,7 +83,7 @@ var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) _Scheduler_queue.push(procId); if (_Scheduler_working) { - return; + return procId; } _Scheduler_working = true; while (true) From bcb4e3bf40b3a07c1504244d455eb743ff85cfb5 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Dec 2019 21:48:07 +0000 Subject: [PATCH 043/170] fix process kill --- src/Platform/RawScheduler.elm | 41 ++++++++++++++++++----------------- src/Platform/Scheduler.elm | 2 +- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 40893754..ed525022 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -48,7 +48,6 @@ type Task val | AsyncAction (DoneCallback val -> TryAbortAction) | SyncAction (() -> Task val) - type alias DoneCallback val = Task val -> () @@ -76,7 +75,7 @@ type ProcessId msg } -type UniqueId = UniqueId Never +type UniqueId = UniqueId UniqueId andThen : (a -> Task b) -> Task a -> Task b @@ -95,6 +94,7 @@ andThen func task = (\newTask -> doneCallback (andThen func newTask)) ) + {-| NON PURE! Will create, **enqueue** and return a new process. @@ -191,28 +191,29 @@ sleep time = {-| Create a task kills a process. + + To kill a process we should try to abort any ongoing async action. + We only allow processes that cannot receive messages to be killed, we will + on the offical core library to lead the way regarding processes that can + receive values. -} -kill : ProcessId msg -> Task () +kill : ProcessId Never -> Task () kill processId = - let - (ProcessState { root }) = - getProcessState processId - in - AsyncAction - (\doneCallback -> + SyncAction + (\() -> let - _ = case root of - Running killer -> - killer () + (ProcessState {root}) = + getProcessState processId + + _ = + case root of + Running killer -> + killer () - Ready _ -> - () + Ready _ -> + () in - let - _ = - doneCallback (Value ()) - in - identity + Value () ) @@ -316,7 +317,7 @@ updateProcessState = getProcessState : ProcessId msg -> ProcessState msg state getProcessState = - Elm.Kernel.Scheduler.getProcess + Elm.Kernel.Scheduler.getProcessState registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index c1e5295f..743ed7e5 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -111,7 +111,7 @@ spawn (Platform.Task task) = {-| Create a task kills a process. -} -kill : ProcessId msg -> Platform.Task never () +kill : ProcessId Never -> Platform.Task never () kill proc = Platform.Task (RawScheduler.andThen From 430b61190725c4bd11c1fa50d2cefbc0389aea20 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 16:04:33 +0000 Subject: [PATCH 044/170] newline after error message --- custom-core.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/custom-core.sh b/custom-core.sh index d7556a78..ee51cd2a 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -4,7 +4,7 @@ set -o errexit; set -o nounset; if [[ ! -v ELM_HOME ]]; then - printf "Please set ELM_HOME!" + printf "Please set ELM_HOME!\n" exit 1 fi From 0d4f118cd34f238b939922e386d93211bc9344f8 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 16:08:33 +0000 Subject: [PATCH 045/170] misc fixes: 1. add _Scheduler_rawSpawn kernel function as elm/time trys to call it. 2. fix manager creation - the elm compiler will set `cmdMap` to `0` and `subMap` to `undefined` !?! With this commit we check `typeof === 'function'` to cover both cases. 3. seperate a processes state and mailbox. Otherwise sending messages to a process can cause reentrant update states. This new approach is cleaner. --- src/Elm/Kernel/Platform.js | 4 +-- src/Elm/Kernel/Scheduler.js | 53 +++++++++++++++++++++++++++++------ src/Platform.elm | 35 ++++++++++++----------- src/Platform/RawScheduler.elm | 39 ++++++++++++-------------- src/Platform/Scheduler.elm | 10 +++++++ 5 files changed, 94 insertions(+), 47 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 23b1d78e..a0607b74 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -130,7 +130,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) const make_setup = fullOnEffects => (setup, sendToApp) => { return A4(setup, sendToApp, init, fullOnEffects, onSelfMsg) } - if (cmdMap === undefined) { + if (typeof cmdMap !== 'function') { // Subscription only effect module return { __cmdMapper: F2((_1, _2) => __Debug_crash(12, 'cmdMap')), @@ -139,7 +139,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) return A3(onEffects, router, subs, state); })), }; - } else if (subMap === undefined) { + } else if (typeof subMap !== 'function') { // Command only effect module return { __cmdMapper: cmdMap, diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index e5ca4725..a8d9108d 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -1,6 +1,7 @@ /* -import Platform.Scheduler as NiceScheduler exposing (succeed, binding) +import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) +import Maybe exposing (Just, Nothing) import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.Utils exposing (Tuple0) */ @@ -8,13 +9,15 @@ import Elm.Kernel.Utils exposing (Tuple0) // COMPATIBILITY /* - * We include these to avoid having to change code - * in other `elm/*` packages. + * We include these to avoid having to change code in other `elm/*` packages. * - * We have to define these as functions rather than - * variables as the implementations of - * elm/core:Platform.Scheduler.* functions may come - * later in the generated javascript file. + * We have to define these as functions rather than variables as the + * implementations of elm/core:Platform.Scheduler.* functions may come later in + * the generated javascript file. + * + * **IMPORTANT**: these functions return `Process.Task`s and + * `Process.ProcessId`s rather than `RawScheduler.Task`s and + * `RawScheduler.ProcessId`s for compatability with `elm/*` package code. */ function _Scheduler_succeed(value) @@ -27,11 +30,17 @@ function _Scheduler_binding(callback) return __NiceScheduler_binding(callback); } +function _Scheduler_rawSpawn(task) +{ + return __NiceScheduler_rawSpawn(task); +} + // SCHEDULER var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); +var _Scheduler_mailboxes = new WeakMap(); function _Scheduler_getGuid() { return _Scheduler_guid++; @@ -71,9 +80,36 @@ var _Scheduler_registerNewProcess = F2((procId, procState) => { } //*/ _Scheduler_processes.set(procId, procState); + _Scheduler_mailboxes.set(procId, []); return procId; }); +var _Scheduler_mailboxAdd = F2((message, procId) => { + const mailbox = _Scheduler_mailboxes.get(procId); + /**__DEBUG/ + if (mailbox === undefined) { + __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); + } + //*/ + mailbox.push(message); + return procId; +}); + +var _Scheduler_mailboxGet = procId => { + const mailbox = _Scheduler_mailboxes.get(procId); + /**__DEBUG/ + if (mailbox === undefined) { + __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); + } + //*/ + const msg = mailbox.shift(); + if (msg === undefined) { + return __Maybe_Nothing; + } else { + return __Maybe_Just(msg); + } +}; + var _Scheduler_working = false; var _Scheduler_queue = []; @@ -109,6 +145,7 @@ var _Scheduler_delay = F3(function (time, value, callback) const _Scheduler_runOnNextTick = F2((callback, val) => { - Promise.resolve(val).then(callback); + setTimeout(() => callback(val), 1); + // Promise.resolve(val).then(callback); return _Utils_Tuple0; }); diff --git a/src/Platform.elm b/src/Platform.elm index 8485e46d..802a4b68 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -112,7 +112,7 @@ worker impl = { stepperBuilder = \ _ _ -> (\ _ _ -> ()) , setupOutgoingPort = setupOutgoingPort , setupIncomingPort = setupIncomingPort - , setupEffects = setupEffects + , setupEffects = instantiateEffectManager , dispatchEffects = dispatchEffects } ) @@ -152,7 +152,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp: appMsg -> () - , selfProcess: RawScheduler.ProcessId selfMsg + , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) } @@ -182,7 +182,7 @@ sendToSelf (Router router) msg = (\() -> RawScheduler.Value (Ok ())) (RawScheduler.send router.selfProcess - msg + (Self msg) ) ) @@ -335,11 +335,6 @@ createEffect isCmd newEffect maybeEffects = (cmdList, newEffect :: subList) -setupEffects : SetupEffects state appMsg selfMsg -setupEffects sendToAppP init onEffects onSelfMsg = - instantiateEffectManager sendToAppP init onEffects onSelfMsg - - instantiateEffectManager : SendToApp appMsg -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) @@ -347,24 +342,32 @@ instantiateEffectManager : SendToApp appMsg -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = let - receiver msg state = + receiver msg stateRes = let (Task task) = - case msg of - Self value -> - onSelfMsg router value state + case stateRes of + Ok state -> + case msg of + Self value -> + onSelfMsg router value state + + App cmds subs -> + onEffects router cmds subs state + + Err e -> + never e - App cmds subs -> - onEffects router cmds subs state in RawScheduler.andThen (\res -> case res of Ok val -> RawScheduler.andThen - (\() -> RawScheduler.Value val) + (\() -> RawScheduler.Value (Ok val)) (RawScheduler.sleep 0) - Err e -> never e + + Err e -> + never e ) task diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index ed525022..51b121e4 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -64,7 +64,6 @@ type ProcessRoot state type ProcessState msg state = ProcessState { root : ProcessRoot state - , mailbox : List msg , receiver : msg -> state -> Task state } @@ -110,7 +109,6 @@ rawSpawn receiver task = ) (ProcessState { root = Ready task - , mailbox = [] , receiver = receiver } ) @@ -146,12 +144,7 @@ rawSend : ProcessId msg -> msg -> ProcessId msg rawSend processId msg = let _ = - updateProcessState - (\(ProcessState procState) -> - ProcessState - { procState | mailbox = procState.mailbox ++ [msg]} - ) - processId + mailboxAdd msg processId in enqueue processId @@ -161,17 +154,13 @@ rawSend processId msg = -} send : ProcessId msg -> msg -> Task () send processId msg = - AsyncAction - (\doneCallback -> + SyncAction + (\() -> let _ = rawSend processId msg in - let - _ = - doneCallback (Value ()) - in - (\() -> ()) + Value () ) @@ -253,18 +242,17 @@ stepper processId (ProcessState process) = (ProcessState process) Ready (Value val) -> - case process.mailbox of - first :: rest -> + case mailboxGet processId of + Just message -> stepper processId (ProcessState { process - | root = Ready (process.receiver first val) - , mailbox = rest + | root = Ready (process.receiver message val) } ) - [] -> + Nothing -> ProcessState process Ready (AsyncAction doEffect) -> @@ -276,7 +264,6 @@ stepper processId (ProcessState process) = (\newRoot -> let _ = - (updateProcessState (\(ProcessState p) -> ProcessState @@ -315,6 +302,16 @@ updateProcessState = Elm.Kernel.Scheduler.updateProcessState +mailboxAdd : msg -> ProcessId msg -> msg +mailboxAdd = + Elm.Kernel.Scheduler.mailboxAdd + + +mailboxGet : ProcessId msg -> Maybe msg +mailboxGet = + Elm.Kernel.Scheduler.mailboxGet + + getProcessState : ProcessId msg -> ProcessState msg state getProcessState = Elm.Kernel.Scheduler.getProcessState diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 743ed7e5..b889d6fb 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -109,6 +109,16 @@ spawn (Platform.Task task) = +{-| This is provided to make __Schdeuler_rawSpawn work! + +TODO(harry) remove once code in other `elm/*` packages has been updated. +-} +rawSpawn : Platform.Task err ok -> Platform.ProcessId +rawSpawn (Platform.Task task) = + Platform.ProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task) + + + {-| Create a task kills a process. -} kill : ProcessId Never -> Platform.Task never () From 6b5dd3edf163480fb59fb84d6c9707f9876c7610 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 16:04:33 +0000 Subject: [PATCH 046/170] use promises (again) for next tick --- src/Elm/Kernel/Scheduler.js | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index a8d9108d..c70df212 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -145,7 +145,6 @@ var _Scheduler_delay = F3(function (time, value, callback) const _Scheduler_runOnNextTick = F2((callback, val) => { - setTimeout(() => callback(val), 1); - // Promise.resolve(val).then(callback); + Promise.resolve(val).then(callback); return _Utils_Tuple0; }); From 0c1ba20fb615222516fe9d8074c675638285e562 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 16:42:55 +0000 Subject: [PATCH 047/170] do not pass sendToApp to setupOutgoingPort --- src/Elm/Kernel/Platform.js | 30 +++++++----------------------- src/Platform.elm | 10 +++++----- 2 files changed, 12 insertions(+), 28 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index a0607b74..ea0b241a 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -75,10 +75,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { managers[key] = __setup(functions.__$setupEffects, sendToApp); } for (const [key, setup] of Object.entries(_Platform_outgoingPorts)) { - const {port, manager} = setup( - functions.__$setupOutgoingPort, - sendToApp - ); + const {port, manager} = setup(functions.__$setupOutgoingPort); ports[key] = port; managers[key] = manager; } @@ -195,16 +192,12 @@ function _Platform_checkPortName(name) function _Platform_outgoingPort(name, converter) { _Platform_checkPortName(name); - _Platform_outgoingPorts[name] = function(setup, sendToApp) { + _Platform_outgoingPorts[name] = setup => { let subs = []; - - function subscribe(callback) - { + const subscribe = callback => { subs.push(callback); - } - - function unsubscribe(callback) - { + }; + const unsubscribe = callback => { // copy subs into a new array in case unsubscribe is called within // a subscribed callback subs = subs.slice(); @@ -213,8 +206,7 @@ function _Platform_outgoingPort(name, converter) { subs.splice(index, 1); } - } - + }; const outgoingPortSend = payload => { const value = __Json_unwrap(converter(payload)); for (const sub of subs) @@ -223,20 +215,12 @@ function _Platform_outgoingPort(name, converter) } return __Utils_Tuple0; }; - - - const manager = A2( - setup, - sendToApp, - outgoingPortSend - ); - return { port: { subscribe, unsubscribe, }, - manager, + manager: setup(outgoingPortSend), } } diff --git a/src/Platform.elm b/src/Platform.elm index 802a4b68..ccdbbcab 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -110,7 +110,7 @@ worker impl = args impl { stepperBuilder = \ _ _ -> (\ _ _ -> ()) - , setupOutgoingPort = setupOutgoingPort + , setupOutgoingPort = setupOutgoingPort , setupIncomingPort = setupIncomingPort , setupEffects = instantiateEffectManager , dispatchEffects = dispatchEffects @@ -190,8 +190,8 @@ sendToSelf (Router router) msg = -- HELPERS -- -setupOutgoingPort : SendToApp msg -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData msg Never) -setupOutgoingPort sendToApp2 outgoingPortSend = +setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) +setupOutgoingPort outgoingPortSend = let init = Task (RawScheduler.Value (Ok ())) @@ -227,7 +227,7 @@ setupOutgoingPort sendToApp2 outgoingPortSend = Task (execInOrder typedCmdList) in - instantiateEffectManager sendToApp2 init onEffects onSelfMsg + instantiateEffectManager (\msg -> never msg) init onEffects onSelfMsg setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (RawScheduler.ProcessId (ReceivedData msg Never), msg -> List (HiddenMySub msg) -> ()) @@ -472,7 +472,7 @@ type alias SetupEffects state appMsg selfMsg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) - , setupOutgoingPort : SendToApp appMsg -> (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData appMsg Never) + , setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (RawScheduler.ProcessId (ReceivedData appMsg Never), appMsg -> List (HiddenMySub appMsg) -> ()) , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () From 8733db9d4fd66856cbabf3d999685a23ea2e13ad Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 17:21:31 +0000 Subject: [PATCH 048/170] tidy scheduler We can do away with rawSetReceiver which was a bit of a cludge introduced to work around the recursive dependancies between `router`, `selfProcess` and `receiver` in `Platform.instantiateEffectManager`. See https://github.com/elm/core/blob/f88d6a6de98802f5cc2d99dc1a0c2734cc5bdd7b/src/Elm/Kernel/Platform.js#L116-L146 for how the offical runtime manages it: using an undefined value which is then set to the correct value later. Obviously that approach is not possible within the elm type system. I do think that this new approach is very nice - it stats to make clear which bits of a process are fixed and which can change. --- src/Elm/Kernel/Scheduler.js | 15 ++-- src/Platform.elm | 17 ++-- src/Platform/RawScheduler.elm | 152 ++++++++++++++-------------------- src/Platform/Scheduler.elm | 2 +- 4 files changed, 78 insertions(+), 108 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index c70df212..9a1edfe3 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -40,6 +40,7 @@ function _Scheduler_rawSpawn(task) var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); +var _Scheduler_receivers = new WeakMap(); var _Scheduler_mailboxes = new WeakMap(); function _Scheduler_getGuid() { @@ -73,17 +74,19 @@ var _Scheduler_updateProcessState = F2((func, id) => { return procState; }); -var _Scheduler_registerNewProcess = F2((procId, procState) => { +var _Scheduler_registerNewProcess = F3((procId, receiver, procState) => { /**__DEBUG/ if (procState === undefined) { __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); } //*/ _Scheduler_processes.set(procId, procState); + _Scheduler_receivers.set(procId, receiver); _Scheduler_mailboxes.set(procId, []); return procId; }); + var _Scheduler_mailboxAdd = F2((message, procId) => { const mailbox = _Scheduler_mailboxes.get(procId); /**__DEBUG/ @@ -95,10 +98,11 @@ var _Scheduler_mailboxAdd = F2((message, procId) => { return procId; }); -var _Scheduler_mailboxGet = procId => { +const _Scheduler_mailboxReceive = F2((procId, state) => { + const receiver = _Scheduler_receivers.get(procId); const mailbox = _Scheduler_mailboxes.get(procId); /**__DEBUG/ - if (mailbox === undefined) { + if (receiver === undefined || mailbox === undefined) { __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); } //*/ @@ -106,10 +110,9 @@ var _Scheduler_mailboxGet = procId => { if (msg === undefined) { return __Maybe_Nothing; } else { - return __Maybe_Just(msg); + return __Maybe_Just(A2(receiver, msg, state)); } -}; - +}); var _Scheduler_working = false; var _Scheduler_queue = []; diff --git a/src/Platform.elm b/src/Platform.elm index ccdbbcab..94b76727 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -372,22 +372,21 @@ instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = task - selfProcess = - RawScheduler.rawSpawn - Elm.Kernel.Platform.crashOnEarlyMessage - (RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) - ) + selfProcessInitRoot = + RawScheduler.andThen + (\() -> init) + (RawScheduler.sleep 0) + selfProcessId = + RawScheduler.newProcessId () router = Router { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) - , selfProcess = selfProcess + , selfProcess = selfProcessId } in - RawScheduler.rawSetReceiver receiver selfProcess + RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId type alias SendToApp msg = diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 51b121e4..9eaaf308 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -62,16 +62,11 @@ type ProcessRoot state type ProcessState msg state - = ProcessState - { root : ProcessRoot state - , receiver : msg -> state -> Task state - } + = ProcessState (ProcessRoot state) type ProcessId msg - = ProcessId - { id : UniqueId - } + = ProcessId UniqueId type UniqueId = UniqueId UniqueId @@ -94,50 +89,38 @@ andThen func task = ) -{-| NON PURE! +{-| Create a new, unique, process id. -Will create, **enqueue** and return a new process. +Will not register the new process id, just create it. To run any tasks using +this process it needs to be registered, for that use `rawSpawn`. -} -rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -rawSpawn receiver task = - enqueue - (registerNewProcess - (ProcessId - { id = Elm.Kernel.Scheduler.getGuid() - } - ) - (ProcessState - { root = Ready task - , receiver = receiver - } - ) - ) +newProcessId : () -> ProcessId msg +newProcessId () = + ProcessId (Elm.Kernel.Scheduler.getGuid()) {-| NON PURE! -Will modify an existing process, **enqueue** and return it. +Will create, register and **enqueue** a new process. -} -rawSetReceiver : (msg -> a -> Task a) -> ProcessId msg -> ProcessId msg -rawSetReceiver receiver processId = - let - _ = - updateProcessState - (\(ProcessState state) -> - ProcessState - { state | receiver = receiver } - ) - processId - in - enqueue processId +rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg +rawSpawn receiver initTask processId = + enqueue + (registerNewProcess + processId + receiver + (ProcessState (Ready initTask)) + ) {-| NON PURE! -Send a message to a process and **enqueue** that process so that it -can perform actions based on the message. +Send a message to a process (adds the message to the processes mailbox) and +**enqueue** that process. + +If the process is "ready" it will then act upon the next message in its mailbox. -} rawSend : ProcessId msg -> msg -> ProcessId msg @@ -149,7 +132,6 @@ rawSend processId msg = enqueue processId - {-| Create a task, if run, will make the process deal with a message. -} send : ProcessId msg -> msg -> Task () @@ -157,7 +139,7 @@ send processId msg = SyncAction (\() -> let - _ = + (ProcessId _) = rawSend processId msg in Value () @@ -169,7 +151,7 @@ send processId msg = spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) spawn receiver task = SyncAction - (\() -> Value (rawSpawn receiver task)) + (\() -> Value (rawSpawn receiver task (newProcessId ()))) {-| Create a task that sleeps for `time` milliseconds @@ -191,10 +173,10 @@ kill processId = SyncAction (\() -> let - (ProcessState {root}) = + (ProcessState root) = getProcessState processId - _ = + () = case root of Running killer -> killer () @@ -218,11 +200,29 @@ enqueue id = enqueueWithStepper (\procId -> let - _ = - updateProcessState (stepper procId) procId + onAsyncActionDone = + runOnNextTick + (\newRoot -> + let + (ProcessState (_)) = + (updateProcessState + (\(ProcessState p) -> + ProcessState (Ready newRoot) + ) + procId + ) + in + let + (ProcessId _) = + enqueue procId + in + () + ) + + (ProcessState _) = + updateProcessState (stepper procId onAsyncActionDone) procId in () - ) id @@ -235,63 +235,31 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state -stepper processId (ProcessState process) = - case process.root of +stepper : ProcessId msg -> (Task state -> ()) -> ProcessState msg state -> ProcessState msg state +stepper processId onAsyncActionDone (ProcessState process) = + case process of Running _ -> (ProcessState process) Ready (Value val) -> - case mailboxGet processId of - Just message -> + case mailboxReceive processId val of + Just newRoot -> stepper processId - (ProcessState - { process - | root = Ready (process.receiver message val) - } - ) + onAsyncActionDone + (ProcessState (Ready newRoot)) Nothing -> ProcessState process Ready (AsyncAction doEffect) -> - ProcessState - { process - | root = Running - (doEffect ( - runOnNextTick - (\newRoot -> - let - _ = - (updateProcessState - (\(ProcessState p) -> - ProcessState - { p | root = Ready newRoot } - ) - processId - ) - in - let - -- todo: avoid enqueue here - _ = - enqueue processId - in - () - ) - )) - } + ProcessState (Running (doEffect onAsyncActionDone)) Ready (SyncAction doEffect) -> - let - newProcess = - { process - | root = Ready (doEffect ()) - } - in stepper processId - (ProcessState newProcess) + onAsyncActionDone + (ProcessState (Ready (doEffect ()))) -- Kernel function redefinitons -- @@ -307,9 +275,9 @@ mailboxAdd = Elm.Kernel.Scheduler.mailboxAdd -mailboxGet : ProcessId msg -> Maybe msg -mailboxGet = - Elm.Kernel.Scheduler.mailboxGet +mailboxReceive : ProcessId msg -> state -> Maybe (Task state) +mailboxReceive = + Elm.Kernel.Scheduler.mailboxReceive getProcessState : ProcessId msg -> ProcessState msg state @@ -317,7 +285,7 @@ getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg +registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index b889d6fb..805717cf 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -115,7 +115,7 @@ TODO(harry) remove once code in other `elm/*` packages has been updated. -} rawSpawn : Platform.Task err ok -> Platform.ProcessId rawSpawn (Platform.Task task) = - Platform.ProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task) + Platform.ProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task (RawScheduler.newProcessId ())) From 18d144906d7d078b24df0015331f116bf2bf76b9 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 17:33:47 +0000 Subject: [PATCH 049/170] complete docs for newProcessId --- src/Platform/RawScheduler.elm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 9eaaf308..d455f603 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -94,6 +94,10 @@ andThen func task = Will not register the new process id, just create it. To run any tasks using this process it needs to be registered, for that use `rawSpawn`. +**WARNING**: trying to enqueue (for example by calling `rawSend` or `send`) +this process before it has been registered will give a **runtime** error. (It +may even fail silently in optimized compiles.) + -} newProcessId : () -> ProcessId msg newProcessId () = @@ -120,7 +124,8 @@ rawSpawn receiver initTask processId = Send a message to a process (adds the message to the processes mailbox) and **enqueue** that process. -If the process is "ready" it will then act upon the next message in its mailbox. +If the process is "ready" it will then act upon the next message in its +mailbox. -} rawSend : ProcessId msg -> msg -> ProcessId msg From d8ac74d77a08b26f2741a39b5f0c8159417e9b75 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 17:46:16 +0000 Subject: [PATCH 050/170] unexpose ctors of Cmd and Sub using kernel magic --- src/Elm/Kernel/Basics.js | 14 ++++++++++++++ src/Platform.elm | 26 ++++++++++++++++++-------- src/Platform/Bag.elm | 8 ++++++++ src/Platform/Cmd.elm | 11 ++--------- src/Platform/Sub.elm | 11 ++--------- 5 files changed, 44 insertions(+), 26 deletions(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index b8c33e63..650173d6 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -31,3 +31,17 @@ var _Basics_modBy0 = function() var _Basics_fudgeType = function(x) { return x; }; + +const _Basics_unwrapTypeWrapper__DEBUG = wrapped => { + const entries = Object.entries(wrapped); + if (entries.length !== 2) { + __Debug_crash(12, 'failedUnwrap'); + } + if (entries[0][0] === '$') { + return entries[1][1]; + } else { + return entries[0][1]; + } +} + +const _Basics_unwrapTypeWrapper__PROD = wrapped => wrapped[0]; diff --git a/src/Platform.elm b/src/Platform.elm index 94b76727..ad84a4e1 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -274,12 +274,12 @@ dispatchEffects : Cmd appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () -dispatchEffects cmd sub = +dispatchEffects cmdBag subBag = let effectsDict = Dict.empty - |> gatherCmds cmd - |> gatherSubs sub + |> gatherCmds cmdBag + |> gatherSubs subBag in \key selfProcess-> let @@ -298,19 +298,19 @@ dispatchEffects cmd sub = gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherCmds (Cmd.Data cmds) effectsDict = +gatherCmds cmdBag effectsDict = List.foldr (\{home, value} dict -> gatherHelper True home value dict) effectsDict - cmds + (unwrapCmd cmdBag) -gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -gatherSubs (Sub.Data subs) effectsDict = +gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherSubs subBag effectsDict = List.foldr (\{home, value} dict -> gatherHelper False home value dict) effectsDict - subs + (unwrapSub subBag) gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) @@ -502,3 +502,13 @@ makeProgramCallable (Program program) = effectManagerNameToString : Bag.EffectManagerName -> String effectManagerNameToString = Elm.Kernel.Platform.effectManagerNameToString + + +unwrapCmd : Cmd a -> Bag.EffectBag a +unwrapCmd = + Elm.Kernel.Basics.unwrapTypeWrapper + + +unwrapSub : Sub a -> Bag.EffectBag a +unwrapSub = + Elm.Kernel.Basics.unwrapTypeWrapper diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index 80cd7ca0..86c5c1c4 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -1,9 +1,17 @@ module Platform.Bag exposing ( LeafType , EffectManagerName + , EffectBag ) +type alias EffectBag msg = + List + { home : EffectManagerName + , value : (LeafType msg) + } + + type LeafType msg = LeafType Kernel diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index ee816adb..bcfa0a8d 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -1,5 +1,5 @@ module Platform.Cmd exposing - ( Cmd(..) + ( Cmd , none , batch , map @@ -48,14 +48,7 @@ Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! -} type Cmd msg - -- Constructor name **must** be same as that used in _Platform_leaf() and - -- the order of record fields **must** be the same too. - = Data - (List - { home : Bag.EffectManagerName - , value : (Bag.LeafType msg) - } - ) + = Data (Bag.EffectBag msg) {-| Tell the runtime that there are no commands. diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 49097c64..b3686cb0 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -1,5 +1,5 @@ module Platform.Sub exposing - ( Sub(..) + ( Sub , none , batch , map @@ -49,14 +49,7 @@ Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! -} type Sub msg - -- Constructor name **must** be same as that used in _Platform_leaf() and - -- the order of record fields **must** be the same too. - = Data - (List - { home : Bag.EffectManagerName - , value : (Bag.LeafType msg) - } - ) + = Data (Bag.EffectBag msg) From 89f549d4c0af23a476779e86a25b6783db6c0c5e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 18:17:06 +0000 Subject: [PATCH 051/170] move use of ProcessId ctor into Scheduler --- src/Platform/Scheduler.elm | 4 ++-- src/Process.elm | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 805717cf..26b602bf 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -121,8 +121,8 @@ rawSpawn (Platform.Task task) = {-| Create a task kills a process. -} -kill : ProcessId Never -> Platform.Task never () -kill proc = +kill : Platform.ProcessId -> Platform.Task never () +kill (Platform.ProcessId proc) = Platform.Task (RawScheduler.andThen (\() -> RawScheduler.Value (Ok ())) diff --git a/src/Process.elm b/src/Process.elm index a71f833a..e6014f77 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -101,5 +101,5 @@ to bail on whatever task it is running. So if there is an HTTP request in flight, it will also abort the request. -} kill : Id -> Task x () -kill (Platform.ProcessId processId) = - Scheduler.kill processId +kill = + Scheduler.kill From 0d67065ee7a31d6ea8bb24efa34bf6dddd758972 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 19:34:02 +0000 Subject: [PATCH 052/170] ensure processId is always an object Before this commit, in optimize mode, processId was just a `number`. This caused an error when the runtime tried to store a processId in a weakMap. --- src/Platform/RawScheduler.elm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index d455f603..4e6bd6b3 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -66,7 +66,7 @@ type ProcessState msg state type ProcessId msg - = ProcessId UniqueId + = ProcessId { id: UniqueId } type UniqueId = UniqueId UniqueId @@ -101,7 +101,7 @@ may even fail silently in optimized compiles.) -} newProcessId : () -> ProcessId msg newProcessId () = - ProcessId (Elm.Kernel.Scheduler.getGuid()) + ProcessId { id = Elm.Kernel.Scheduler.getGuid() } {-| NON PURE! From fcc344419d51cbd5976691e959629f7ce001582d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 19:35:07 +0000 Subject: [PATCH 053/170] remove old file --- elm-minimal | 1 - 1 file changed, 1 deletion(-) delete mode 160000 elm-minimal diff --git a/elm-minimal b/elm-minimal deleted file mode 160000 index a6f5b06e..00000000 --- a/elm-minimal +++ /dev/null @@ -1 +0,0 @@ -Subproject commit a6f5b06e82adf9bd058d5a85dc12e9cbd4d16bab From dc751317e184d5654c12de40cf15fcda2f693344 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 19:35:23 +0000 Subject: [PATCH 054/170] fix unwrapTypeWrapper in optimize mode In optimize mode type wrappers are removed by the compiler. Therefore, unwrapping should be a no-op. --- src/Elm/Kernel/Basics.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 650173d6..9b06b04c 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -44,4 +44,4 @@ const _Basics_unwrapTypeWrapper__DEBUG = wrapped => { } } -const _Basics_unwrapTypeWrapper__PROD = wrapped => wrapped[0]; +const _Basics_unwrapTypeWrapper__PROD = wrapped => wrapped; From c3ae49eb24cc876d643624b3e608b671cc4d2e11 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 19:38:53 +0000 Subject: [PATCH 055/170] stop exposing runtime details from `Platform` This does introduce more kernel function calls but I think that is unavoidable. --- src/Elm/Kernel/Platform.js | 8 +-- src/Platform.elm | 2 +- src/Platform/Scheduler.elm | 132 ++++++++++++++++++++++++++++--------- 3 files changed, 104 insertions(+), 38 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index ea0b241a..11bbf273 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -5,6 +5,7 @@ import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) import Elm.Kernel.List exposing (Cons, Nil) import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) +import Platform exposing (Task, ProcessId) */ @@ -283,12 +284,9 @@ const _Platform_getSubMapper = home => { return _Platform_effectManagers[home].__subMapper; }; +const _Platform_wrapTask = task => __Platform_Task(task); -const _Platform_crashOnEarlyMessage = F2((_1, _2) => - __Debug_crash(12, 'earlyMsg') -); - - +const _Platform_wrapProcessId = processId => __Platform_ProcessId(processId); // EXPORT ELM MODULES // diff --git a/src/Platform.elm b/src/Platform.elm index ad84a4e1..fcefcab3 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -1,6 +1,6 @@ module Platform exposing ( Program, worker - , Task(..), ProcessId(..) + , Task, ProcessId , Router, sendToApp, sendToSelf ) diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 26b602bf..c51eb84f 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -2,15 +2,53 @@ module Platform.Scheduler exposing (..) {-| -## Module notes: - -TODO(harry) explain need for this module and how it relates to Platform and - Platform.RawScheduler. +The definition of the `Task` and `ProcessId` really belong in the +`Platform.RawScheduler` module for two reasons. + +1. Tasks and processes are created, run and managed by the scheduler. It makes + semantic sense for the scheduler to also contain the type defintion. +2. The `Platform.RawScheduler` module is private to `elm/core`, therefore other + core functions could access the type constructurs if they were contained + within the module. `Platform` is a public module and therefore we cannot + expose the type constructures to core functions without also exposing them + to user functions. + +However, for two reasons they must instead be defined in the `Platform` module. + +1. The official elm compiler regards changing a type definition to a type alias + to be a MAJOR change. Moving the type definition out of `Platform` and + replacing it with a type alias would count as a MAJOR change. As one of my + aims for this alternative elm/core library was no MAJOR (or even MINOR + changes) according to elm diff. Moving `Task` and `ProcessId` out of + `Platform` would defeat this aim. +2. More seriously, there are hard coded checks in the elm compiler ensuring + effect modules are valid. The compiler checks that the module defines the + needed functions (for example `onEffects`, `onSelfMsg`, etc) but it also + checks that the type signatures of these functions are correct. If we + replace the type definitions in `Platform` by type aliases all these checks + start to fail. For example, the compile checks that `Task.onEffects` returns + a `Platform.Task` but actually it returns `Platform.RawScheduler.Task` (via + a type alias in `Platform` but type aliases are transparent to the compiler + at this point during compiliation). + +In an attempt to get the best of both worlds we define `Task` and `ProcessId` +types in `Platform.RawScheduler` and then in `Platform` we define + +```elm +type Task error value = Task (Platform.RawScheduler.Task (Result error value)) +``` + +This module provides functions that work with `Platform.Task`s and +`Platform.ProcessId`s. However, as the type constructors are not exposed (if +they were the user code could use the runtime internals), this module resorts +to some kernel code magic to wrap and unwrap `Task`s and `Process`s. -} import Platform import Platform.RawScheduler as RawScheduler +import Elm.Kernel.Platform +import Elm.Kernel.Basics import Result exposing (Result(..)) import Basics exposing (..) @@ -28,45 +66,42 @@ type alias TryAbortAction = succeed : ok -> Platform.Task never ok succeed val = - Platform.Task (RawScheduler.Value (Ok val)) + wrapTask (RawScheduler.Value (Ok val)) fail : err -> Platform.Task err never fail e = - Platform.Task (RawScheduler.Value (Err e)) + wrapTask (RawScheduler.Value (Err e)) binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok binding callback = - Platform.Task + wrapTask (RawScheduler.AsyncAction - (\doneCallback -> callback (\(Platform.Task task) -> doneCallback task)) + (\doneCallback -> callback (taskFn (\task -> doneCallback task))) ) andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 -andThen func (Platform.Task task) = - Platform.Task +andThen func = + wrapTaskFn (\task -> (RawScheduler.andThen (\r -> case r of Ok val -> - let - (Platform.Task rawTask) = - func val - in - rawTask + unwrapTask (func val) Err e -> RawScheduler.Value (Err e) ) task ) + ) onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok -onError func (Platform.Task task) = - Platform.Task +onError func = + wrapTaskFn (\task -> (RawScheduler.andThen (\r -> case r of @@ -74,21 +109,18 @@ onError func (Platform.Task task) = RawScheduler.Value (Ok val) Err e -> - let - (Platform.Task rawTask) = - func e - in - rawTask + unwrapTask (func e) ) task ) + ) {-| Create a task, if run, will make the process deal with a message. -} send : ProcessId msg -> msg -> Platform.Task never () send proc msg = - Platform.Task + wrapTask (RawScheduler.andThen (\() -> RawScheduler.Value (Ok ())) (RawScheduler.send proc msg) @@ -100,12 +132,13 @@ send proc msg = There is no way to send messages to a process spawned in this way. -} spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId -spawn (Platform.Task task) = - Platform.Task +spawn = + wrapTaskFn (\task -> (RawScheduler.andThen - (\proc -> RawScheduler.Value (Ok (Platform.ProcessId proc))) + (\proc -> RawScheduler.Value (Ok (wrapProcessId proc))) (RawScheduler.spawn (\msg state -> never msg) task) ) + ) @@ -114,19 +147,21 @@ spawn (Platform.Task task) = TODO(harry) remove once code in other `elm/*` packages has been updated. -} rawSpawn : Platform.Task err ok -> Platform.ProcessId -rawSpawn (Platform.Task task) = - Platform.ProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task (RawScheduler.newProcessId ())) +rawSpawn = + taskFn (\task -> + wrapProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task (RawScheduler.newProcessId ())) + ) {-| Create a task kills a process. -} kill : Platform.ProcessId -> Platform.Task never () -kill (Platform.ProcessId proc) = - Platform.Task +kill processId = + wrapTask (RawScheduler.andThen (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.kill proc) + (RawScheduler.kill (unwrapProcessId processId)) ) @@ -134,8 +169,41 @@ kill (Platform.ProcessId proc) = -} sleep : Float -> Platform.Task x () sleep time = - Platform.Task + wrapTask (RawScheduler.andThen (\() -> RawScheduler.Value (Ok ())) (RawScheduler.sleep time) ) + + +-- wrapping helpers -- + + +wrapTaskFn: (RawScheduler.Task (Result e1 o1) -> RawScheduler.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 +wrapTaskFn fn task = + wrapTask (taskFn fn task) + + +taskFn: (RawScheduler.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a +taskFn fn task = + fn (unwrapTask task) + + +wrapTask: (RawScheduler.Task (Result e o)) -> Platform.Task e o +wrapTask = + Elm.Kernel.Platform.wrapTask + + +unwrapTask: Platform.Task e o -> (RawScheduler.Task (Result e o)) +unwrapTask = + Elm.Kernel.Basics.unwrapTypeWrapper + + +wrapProcessId: ProcessId Never -> Platform.ProcessId +wrapProcessId = + Elm.Kernel.Platform.wrapProcessId + + +unwrapProcessId: Platform.ProcessId -> ProcessId Never +unwrapProcessId = + Elm.Kernel.Basics.unwrapTypeWrapper From 9fdaca6e414226d3abf6894888a02efd8cccf815 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 20:56:12 +0000 Subject: [PATCH 056/170] update readme --- README.md | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index d480ed7e..b396982c 100644 --- a/README.md +++ b/README.md @@ -10,6 +10,7 @@ ## Rules -* Each kernel function may only be referenced by an elm definition of the same name. - Other elm functions **must** call the elm version of this function. -* Kernel functions may **not** call elm functions. +* Each kernel function may only be called via a type annotated redefinition in an elm file. +* Kernel functions may **not** call globally defined elm functions. + Elm functions _can_ be passed into kernel functions as arguments. +* Kernel functions may **not** call other kernel functions. From 941e53bcdc271972bcb41b5a830ef5bcdb10f559 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 20:59:48 +0000 Subject: [PATCH 057/170] run elm format --- src/Array.elm | 633 ++++++++++++++++++-------------- src/Basics.elm | 665 +++++++++++++++++++++------------ src/Bitwise.elm | 84 +++-- src/Char.elm | 200 ++++++---- src/Debug.elm | 34 +- src/Dict.elm | 669 ++++++++++++++++++---------------- src/Elm/JsArray.elm | 46 +-- src/List.elm | 561 ++++++++++++++++------------ src/Maybe.elm | 212 ++++++----- src/Platform.elm | 637 +++++++++++++++++--------------- src/Platform/Bag.elm | 25 +- src/Platform/Cmd.elm | 53 +-- src/Platform/RawScheduler.elm | 291 +++++++-------- src/Platform/Scheduler.elm | 212 +++++------ src/Platform/Sub.elm | 60 +-- src/Process.elm | 30 +- src/Result.elm | 250 +++++++------ src/Set.elm | 81 ++-- src/String.elm | 359 ++++++++++++------ src/Task.elm | 248 ++++++++----- src/Tuple.elm | 84 +++-- 21 files changed, 3125 insertions(+), 2309 deletions(-) diff --git a/src/Array.elm b/src/Array.elm index 8c180605..68117490 100644 --- a/src/Array.elm +++ b/src/Array.elm @@ -1,47 +1,45 @@ -module Array - exposing - ( Array - , empty - , isEmpty - , length - , initialize - , repeat - , fromList - , get - , set - , push - , toList - , toIndexedList - , foldr - , foldl - , filter - , map - , indexedMap - , append - , slice - ) +module Array exposing + ( Array + , empty, initialize, repeat, fromList + , isEmpty, length, get + , set, push, append, slice + , toList, toIndexedList + , map, indexedMap, foldl, foldr, filter + ) {-| Fast immutable arrays. The elements in an array must have the same type. + # Arrays + @docs Array + # Creation + @docs empty, initialize, repeat, fromList + # Query + @docs isEmpty, length, get + # Manipulate + @docs set, push, append, slice + # Lists + @docs toList, toIndexedList + # Transform + @docs map, indexedMap, foldl, foldr, filter --} +-} import Basics exposing (..) import Bitwise @@ -65,6 +63,7 @@ tree, and we do this by dividing it into several smaller numbers (see `shiftStep` documentation). By dividing the index into smaller numbers, we will always get a range which is a power of two (2 bits gives 0-3, 3 gives 0-7, 4 gives 0-15...). + -} branchFactor : Int branchFactor = @@ -88,6 +87,7 @@ read which of the 32 branches to take. The `shiftStep` specifices how many bits are required to represent the branching factor. + -} shiftStep : Int shiftStep = @@ -136,6 +136,7 @@ type alias Tree a = {-| Return an empty array. length empty == 0 + -} empty : Array a empty = @@ -149,6 +150,7 @@ empty = {-| Determine if an array is empty. isEmpty empty == True + -} isEmpty : Array a -> Bool isEmpty (Array_elm_builtin len _ _ _) = @@ -157,7 +159,8 @@ isEmpty (Array_elm_builtin len _ _ _) = {-| Return the length of an array. - length (fromList [1,2,3]) == 3 + length (fromList [ 1, 2, 3 ]) == 3 + -} length : Array a -> Int length (Array_elm_builtin len _ _ _) = @@ -167,14 +170,18 @@ length (Array_elm_builtin len _ _ _) = {-| Initialize an array. `initialize n f` creates an array of length `n` with the element at index `i` initialized to the result of `(f i)`. - initialize 4 identity == fromList [0,1,2,3] - initialize 4 (\n -> n*n) == fromList [0,1,4,9] - initialize 4 (always 0) == fromList [0,0,0,0] + initialize 4 identity == fromList [ 0, 1, 2, 3 ] + + initialize 4 (\n -> n * n) == fromList [ 0, 1, 4, 9 ] + + initialize 4 (always 0) == fromList [ 0, 0, 0, 0 ] + -} initialize : Int -> (Int -> a) -> Array a initialize len fn = if len <= 0 then empty + else let tailLen = @@ -186,7 +193,7 @@ initialize len fn = initialFromIndex = len - tailLen - branchFactor in - initializeHelp fn initialFromIndex len [] tail + initializeHelp fn initialFromIndex len [] tail initializeHelp : (Int -> a) -> Int -> Int -> List (Node a) -> JsArray a -> Array a @@ -197,25 +204,28 @@ initializeHelp fn fromIndex len nodeList tail = , nodeList = nodeList , nodeListSize = len // branchFactor } + else let leaf = Leaf <| JsArray.initialize branchFactor fromIndex fn in - initializeHelp - fn - (fromIndex - branchFactor) - len - (leaf :: nodeList) - tail + initializeHelp + fn + (fromIndex - branchFactor) + len + (leaf :: nodeList) + tail {-| Creates an array with a given length, filled with a default element. - repeat 5 0 == fromList [0,0,0,0,0] - repeat 3 "cat" == fromList ["cat","cat","cat"] + repeat 5 0 == fromList [ 0, 0, 0, 0, 0 ] + + repeat 3 "cat" == fromList [ "cat", "cat", "cat" ] Notice that `repeat 3 x` is the same as `initialize 3 (always x)`. + -} repeat : Int -> a -> Array a repeat n e = @@ -240,33 +250,40 @@ fromListHelp list nodeList nodeListSize = ( jsArray, remainingItems ) = JsArray.initializeFromList branchFactor list in - if JsArray.length jsArray < branchFactor then - builderToArray True - { tail = jsArray - , nodeList = nodeList - , nodeListSize = nodeListSize - } - else - fromListHelp - remainingItems - (Leaf jsArray :: nodeList) - (nodeListSize + 1) + if JsArray.length jsArray < branchFactor then + builderToArray True + { tail = jsArray + , nodeList = nodeList + , nodeListSize = nodeListSize + } + + else + fromListHelp + remainingItems + (Leaf jsArray :: nodeList) + (nodeListSize + 1) {-| Return `Just` the element at the index or `Nothing` if the index is out of range. - get 0 (fromList [0,1,2]) == Just 0 - get 2 (fromList [0,1,2]) == Just 2 - get 5 (fromList [0,1,2]) == Nothing - get -1 (fromList [0,1,2]) == Nothing + get 0 (fromList [ 0, 1, 2 ]) == Just 0 + + get 2 (fromList [ 0, 1, 2 ]) == Just 2 + + get 5 (fromList [ 0, 1, 2 ]) == Nothing + + get -1 (fromList [ 0, 1, 2 ]) == Nothing + -} get : Int -> Array a -> Maybe a get index (Array_elm_builtin len startShift tree tail) = if index < 0 || index >= len then Nothing + else if index >= tailIndex len then Just <| JsArray.unsafeGet (Bitwise.and bitMask index) tail + else Just <| getHelp startShift index tree @@ -277,12 +294,12 @@ getHelp shift index tree = pos = Bitwise.and bitMask <| Bitwise.shiftRightZfBy shift index in - case JsArray.unsafeGet pos tree of - SubTree subTree -> - getHelp (shift - shiftStep) index subTree + case JsArray.unsafeGet pos tree of + SubTree subTree -> + getHelp (shift - shiftStep) index subTree - Leaf values -> - JsArray.unsafeGet (Bitwise.and bitMask index) values + Leaf values -> + JsArray.unsafeGet (Bitwise.and bitMask index) values {-| Given an array length, return the index of the first element in the tail. @@ -298,15 +315,18 @@ tailIndex len = {-| Set the element at a particular index. Returns an updated array. If the index is out of range, the array is unaltered. - set 1 7 (fromList [1,2,3]) == fromList [1,7,3] + set 1 7 (fromList [ 1, 2, 3 ]) == fromList [ 1, 7, 3 ] + -} set : Int -> a -> Array a -> Array a set index value ((Array_elm_builtin len startShift tree tail) as array) = if index < 0 || index >= len then array + else if index >= tailIndex len then Array_elm_builtin len startShift tree <| JsArray.unsafeSet (Bitwise.and bitMask index) value tail + else Array_elm_builtin len @@ -321,25 +341,26 @@ setHelp shift index value tree = pos = Bitwise.and bitMask <| Bitwise.shiftRightZfBy shift index in - case JsArray.unsafeGet pos tree of - SubTree subTree -> - let - newSub = - setHelp (shift - shiftStep) index value subTree - in - JsArray.unsafeSet pos (SubTree newSub) tree + case JsArray.unsafeGet pos tree of + SubTree subTree -> + let + newSub = + setHelp (shift - shiftStep) index value subTree + in + JsArray.unsafeSet pos (SubTree newSub) tree - Leaf values -> - let - newLeaf = - JsArray.unsafeSet (Bitwise.and bitMask index) value values - in - JsArray.unsafeSet pos (Leaf newLeaf) tree + Leaf values -> + let + newLeaf = + JsArray.unsafeSet (Bitwise.and bitMask index) value values + in + JsArray.unsafeSet pos (Leaf newLeaf) tree {-| Push an element onto the end of an array. - push 3 (fromList [1,2]) == fromList [1,2,3] + push 3 (fromList [ 1, 2 ]) == fromList [ 1, 2, 3 ] + -} push : a -> Array a -> Array a push a ((Array_elm_builtin _ _ _ tail) as array) = @@ -352,6 +373,7 @@ push a ((Array_elm_builtin _ _ _ tail) as array) = WARNING: For performance reasons, this function does not check if the new tail has a length equal to or beneath the `branchFactor`. Make sure this is the case before using this function. + -} unsafeReplaceTail : JsArray a -> Array a -> Array a unsafeReplaceTail newTail (Array_elm_builtin len startShift tree tail) = @@ -365,37 +387,39 @@ unsafeReplaceTail newTail (Array_elm_builtin len startShift tree tail) = newArrayLen = len + (newTailLen - originalTailLen) in - if newTailLen == branchFactor then + if newTailLen == branchFactor then + let + overflow = + Bitwise.shiftRightZfBy shiftStep newArrayLen > Bitwise.shiftLeftBy startShift 1 + in + if overflow then let - overflow = - Bitwise.shiftRightZfBy shiftStep newArrayLen > Bitwise.shiftLeftBy startShift 1 + newShift = + startShift + shiftStep + + newTree = + JsArray.singleton (SubTree tree) + |> insertTailInTree newShift len newTail in - if overflow then - let - newShift = - startShift + shiftStep + Array_elm_builtin + newArrayLen + newShift + newTree + JsArray.empty - newTree = - JsArray.singleton (SubTree tree) - |> insertTailInTree newShift len newTail - in - Array_elm_builtin - newArrayLen - newShift - newTree - JsArray.empty - else - Array_elm_builtin - newArrayLen - startShift - (insertTailInTree startShift len newTail tree) - JsArray.empty else Array_elm_builtin newArrayLen startShift - tree - newTail + (insertTailInTree startShift len newTail tree) + JsArray.empty + + else + Array_elm_builtin + newArrayLen + startShift + tree + newTail insertTailInTree : Int -> Int -> JsArray a -> Tree a -> Tree a @@ -404,45 +428,48 @@ insertTailInTree shift index tail tree = pos = Bitwise.and bitMask <| Bitwise.shiftRightZfBy shift index in - if pos >= JsArray.length tree then - if shift == 5 then - JsArray.push (Leaf tail) tree - else + if pos >= JsArray.length tree then + if shift == 5 then + JsArray.push (Leaf tail) tree + + else + let + newSub = + JsArray.empty + |> insertTailInTree (shift - shiftStep) index tail + |> SubTree + in + JsArray.push newSub tree + + else + let + value = + JsArray.unsafeGet pos tree + in + case value of + SubTree subTree -> let newSub = - JsArray.empty + subTree |> insertTailInTree (shift - shiftStep) index tail |> SubTree in - JsArray.push newSub tree - else - let - value = - JsArray.unsafeGet pos tree - in - case value of - SubTree subTree -> - let - newSub = - subTree - |> insertTailInTree (shift - shiftStep) index tail - |> SubTree - in - JsArray.unsafeSet pos newSub tree - - Leaf _ -> - let - newSub = - JsArray.singleton value - |> insertTailInTree (shift - shiftStep) index tail - |> SubTree - in - JsArray.unsafeSet pos newSub tree + JsArray.unsafeSet pos newSub tree + + Leaf _ -> + let + newSub = + JsArray.singleton value + |> insertTailInTree (shift - shiftStep) index tail + |> SubTree + in + JsArray.unsafeSet pos newSub tree {-| Create a list of elements from an array. - toList (fromList [3,5,8]) == [3,5,8] + toList (fromList [ 3, 5, 8 ]) == [ 3, 5, 8 ] + -} toList : Array a -> List a toList array = @@ -452,20 +479,22 @@ toList array = {-| Create an indexed list from an array. Each element of the array will be paired with its index. - toIndexedList (fromList ["cat","dog"]) == [(0,"cat"), (1,"dog")] + toIndexedList (fromList [ "cat", "dog" ]) == [ ( 0, "cat" ), ( 1, "dog" ) ] + -} toIndexedList : Array a -> List ( Int, a ) toIndexedList ((Array_elm_builtin len _ _ _) as array) = let helper entry ( index, list ) = - ( index - 1, (index,entry) :: list ) + ( index - 1, ( index, entry ) :: list ) in - Tuple.second (foldr helper ( len - 1, [] ) array) + Tuple.second (foldr helper ( len - 1, [] ) array) {-| Reduce an array from the right. Read `foldr` as fold from the right. foldr (+) 0 (repeat 3 5) == 15 + -} foldr : (a -> b -> b) -> b -> Array a -> b foldr func baseCase (Array_elm_builtin _ _ tree tail) = @@ -478,12 +507,13 @@ foldr func baseCase (Array_elm_builtin _ _ tree tail) = Leaf values -> JsArray.foldr func acc values in - JsArray.foldr helper (JsArray.foldr func baseCase tail) tree + JsArray.foldr helper (JsArray.foldr func baseCase tail) tree {-| Reduce an array from the left. Read `foldl` as fold from the left. - foldl (::) [] (fromList [1,2,3]) == [3,2,1] + foldl (::) [] (fromList [ 1, 2, 3 ]) == [ 3, 2, 1 ] + -} foldl : (a -> b -> b) -> b -> Array a -> b foldl func baseCase (Array_elm_builtin _ _ tree tail) = @@ -496,21 +526,34 @@ foldl func baseCase (Array_elm_builtin _ _ tree tail) = Leaf values -> JsArray.foldl func acc values in - JsArray.foldl func (JsArray.foldl helper baseCase tree) tail + JsArray.foldl func (JsArray.foldl helper baseCase tree) tail {-| Keep elements that pass the test. - filter isEven (fromList [1,2,3,4,5,6]) == (fromList [2,4,6]) + filter isEven (fromList [ 1, 2, 3, 4, 5, 6 ]) == fromList [ 2, 4, 6 ] + -} filter : (a -> Bool) -> Array a -> Array a filter isGood array = - fromList (foldr (\x xs -> if isGood x then x :: xs else xs) [] array) + fromList + (foldr + (\x xs -> + if isGood x then + x :: xs + + else + xs + ) + [] + array + ) {-| Apply a function on every element in an array. - map sqrt (fromList [1,4,9]) == fromList [1,2,3] + map sqrt (fromList [ 1, 4, 9 ]) == fromList [ 1, 2, 3 ] + -} map : (a -> b) -> Array a -> Array b map func (Array_elm_builtin len startShift tree tail) = @@ -523,16 +566,17 @@ map func (Array_elm_builtin len startShift tree tail) = Leaf values -> Leaf <| JsArray.map func values in - Array_elm_builtin - len - startShift - (JsArray.map helper tree) - (JsArray.map func tail) + Array_elm_builtin + len + startShift + (JsArray.map helper tree) + (JsArray.map func tail) {-| Apply a function on every element with its index as first argument. - indexedMap (*) (fromList [5,5,5]) == fromList [0,5,10] + indexedMap (*) (fromList [ 5, 5, 5 ]) == fromList [ 0, 5, 10 ] + -} indexedMap : (Int -> a -> b) -> Array a -> Array b indexedMap func (Array_elm_builtin len _ tree tail) = @@ -550,10 +594,10 @@ indexedMap func (Array_elm_builtin len _ tree tail) = mappedLeaf = Leaf <| JsArray.indexedMap func offset leaf in - { tail = builder.tail - , nodeList = mappedLeaf :: builder.nodeList - , nodeListSize = builder.nodeListSize + 1 - } + { tail = builder.tail + , nodeList = mappedLeaf :: builder.nodeList + , nodeListSize = builder.nodeListSize + 1 + } initialBuilder = { tail = JsArray.indexedMap func (tailIndex len) tail @@ -561,12 +605,13 @@ indexedMap func (Array_elm_builtin len _ tree tail) = , nodeListSize = 0 } in - builderToArray True (JsArray.foldl helper initialBuilder tree) + builderToArray True (JsArray.foldl helper initialBuilder tree) {-| Append two arrays to a new one. - append (repeat 2 42) (repeat 3 81) == fromList [42,42,81,81,81] + append (repeat 2 42) (repeat 3 81) == fromList [ 42, 42, 81, 81, 81 ] + -} append : Array a -> Array a -> Array a append ((Array_elm_builtin _ _ _ aTail) as a) (Array_elm_builtin bLen _ bTree bTail) = @@ -581,8 +626,9 @@ append ((Array_elm_builtin _ _ _ aTail) as a) (Array_elm_builtin bLen _ bTree bT Leaf leaf -> appendHelpTree leaf array in - JsArray.foldl foldHelper a bTree - |> appendHelpTree bTail + JsArray.foldl foldHelper a bTree + |> appendHelpTree bTail + else let foldHelper node builder = @@ -593,9 +639,9 @@ append ((Array_elm_builtin _ _ _ aTail) as a) (Array_elm_builtin bLen _ bTree bT Leaf leaf -> appendHelpBuilder leaf builder in - JsArray.foldl foldHelper (builderFromArray a) bTree - |> appendHelpBuilder bTail - |> builderToArray True + JsArray.foldl foldHelper (builderFromArray a) bTree + |> appendHelpBuilder bTail + |> builderToArray True appendHelpTree : JsArray a -> Array a -> Array a @@ -608,19 +654,20 @@ appendHelpTree toAppend ((Array_elm_builtin len _ tree tail) as array) = JsArray.length toAppend notAppended = - branchFactor - (JsArray.length tail) - itemsToAppend + branchFactor - JsArray.length tail - itemsToAppend newArray = unsafeReplaceTail appended array in - if notAppended < 0 then - let - nextTail = - JsArray.slice notAppended itemsToAppend toAppend - in - unsafeReplaceTail nextTail newArray - else - newArray + if notAppended < 0 then + let + nextTail = + JsArray.slice notAppended itemsToAppend toAppend + in + unsafeReplaceTail nextTail newArray + + else + newArray appendHelpBuilder : JsArray a -> Builder a -> Builder a @@ -633,23 +680,25 @@ appendHelpBuilder tail builder = JsArray.length tail notAppended = - branchFactor - (JsArray.length builder.tail) - tailLen + branchFactor - JsArray.length builder.tail - tailLen in - if notAppended < 0 then - { tail = JsArray.slice notAppended tailLen tail - , nodeList = Leaf appended :: builder.nodeList - , nodeListSize = builder.nodeListSize + 1 - } - else if notAppended == 0 then - { tail = JsArray.empty - , nodeList = Leaf appended :: builder.nodeList - , nodeListSize = builder.nodeListSize + 1 - } - else - { tail = appended - , nodeList = builder.nodeList - , nodeListSize = builder.nodeListSize - } + if notAppended < 0 then + { tail = JsArray.slice notAppended tailLen tail + , nodeList = Leaf appended :: builder.nodeList + , nodeListSize = builder.nodeListSize + 1 + } + + else if notAppended == 0 then + { tail = JsArray.empty + , nodeList = Leaf appended :: builder.nodeList + , nodeListSize = builder.nodeListSize + 1 + } + + else + { tail = appended + , nodeList = builder.nodeList + , nodeListSize = builder.nodeListSize + } {-| Get a sub-section of an array: `(slice start end array)`. The `start` is a @@ -657,17 +706,20 @@ zero-based index where we will start our slice. The `end` is a zero-based index that indicates the end of the slice. The slice extracts up to but not including `end`. - slice 0 3 (fromList [0,1,2,3,4]) == fromList [0,1,2] - slice 1 4 (fromList [0,1,2,3,4]) == fromList [1,2,3] + slice 0 3 (fromList [ 0, 1, 2, 3, 4 ]) == fromList [ 0, 1, 2 ] + + slice 1 4 (fromList [ 0, 1, 2, 3, 4 ]) == fromList [ 1, 2, 3 ] Both the `start` and `end` indexes can be negative, indicating an offset from the end of the array. - slice 1 -1 (fromList [0,1,2,3,4]) == fromList [1,2,3] - slice -2 5 (fromList [0,1,2,3,4]) == fromList [3,4] + slice 1 -1 (fromList [ 0, 1, 2, 3, 4 ]) == fromList [ 1, 2, 3 ] + + slice -2 5 (fromList [ 0, 1, 2, 3, 4 ]) == fromList [ 3, 4 ] This makes it pretty easy to `pop` the last element off of an array: `slice 0 -1 array` + -} slice : Int -> Int -> Array a -> Array a slice from to array = @@ -678,19 +730,23 @@ slice from to array = correctTo = translateIndex to array in - if correctFrom > correctTo then - empty - else - array - |> sliceRight correctTo - |> sliceLeft correctFrom + if correctFrom > correctTo then + empty + + else + array + |> sliceRight correctTo + |> sliceLeft correctFrom {-| Given a relative array index, convert it into an absolute one. translateIndex -1 someArray == someArray.length - 1 + translateIndex -10 someArray == someArray.length - 10 + translateIndex 5 someArray == 5 + -} translateIndex : Int -> Array a -> Int translateIndex index (Array_elm_builtin len _ _ _) = @@ -698,36 +754,44 @@ translateIndex index (Array_elm_builtin len _ _ _) = posIndex = if index < 0 then len + index + else index in - if posIndex < 0 then - 0 - else if posIndex > len then - len - else - posIndex + if posIndex < 0 then + 0 + + else if posIndex > len then + len + + else + posIndex {-| This function slices the tree from the right. First, two things are tested: -1. If the array does not need slicing, return the original array. -2. If the array can be sliced by only slicing the tail, slice the tail. + +1. If the array does not need slicing, return the original array. +2. If the array can be sliced by only slicing the tail, slice the tail. Otherwise, we do the following: -1. Find the new tail in the tree, promote it to the root tail position and -slice it. -2. Slice every sub tree. -3. Promote subTrees until the tree has the correct height. + +1. Find the new tail in the tree, promote it to the root tail position and + slice it. +2. Slice every sub tree. +3. Promote subTrees until the tree has the correct height. + -} sliceRight : Int -> Array a -> Array a sliceRight end ((Array_elm_builtin len startShift tree tail) as array) = if end == len then array + else if end >= tailIndex len then Array_elm_builtin end startShift tree <| JsArray.slice 0 (Bitwise.and bitMask end) tail + else let endIdx = @@ -743,14 +807,14 @@ sliceRight end ((Array_elm_builtin len startShift tree tail) as array) = newShift = max 5 <| depth * shiftStep in - Array_elm_builtin - end - newShift - (tree - |> sliceTree startShift endIdx - |> hoistTree startShift newShift - ) - (fetchNewTail startShift end endIdx tree) + Array_elm_builtin + end + newShift + (tree + |> sliceTree startShift endIdx + |> hoistTree startShift newShift + ) + (fetchNewTail startShift end endIdx tree) {-| Slice and return the `Leaf` node after what is to be the last node @@ -762,12 +826,12 @@ fetchNewTail shift end treeEnd tree = pos = Bitwise.and bitMask <| Bitwise.shiftRightZfBy shift treeEnd in - case JsArray.unsafeGet pos tree of - SubTree sub -> - fetchNewTail (shift - shiftStep) end treeEnd sub + case JsArray.unsafeGet pos tree of + SubTree sub -> + fetchNewTail (shift - shiftStep) end treeEnd sub - Leaf values -> - JsArray.slice 0 (Bitwise.and bitMask end) values + Leaf values -> + JsArray.slice 0 (Bitwise.and bitMask end) values {-| Shorten the root `Node` of the tree so it is long enough to contain @@ -780,25 +844,26 @@ sliceTree shift endIdx tree = lastPos = Bitwise.and bitMask <| Bitwise.shiftRightZfBy shift endIdx in - case JsArray.unsafeGet lastPos tree of - SubTree sub -> - let - newSub = - sliceTree (shift - shiftStep) endIdx sub - in - if JsArray.length newSub == 0 then - -- The sub is empty, slice it away - JsArray.slice 0 lastPos tree - else - tree - |> JsArray.slice 0 (lastPos + 1) - |> JsArray.unsafeSet lastPos (SubTree newSub) - - -- This is supposed to be the new tail. Fetched by `fetchNewTail`. - -- Slice up to, but not including, this point. - Leaf _ -> + case JsArray.unsafeGet lastPos tree of + SubTree sub -> + let + newSub = + sliceTree (shift - shiftStep) endIdx sub + in + if JsArray.length newSub == 0 then + -- The sub is empty, slice it away JsArray.slice 0 lastPos tree + else + tree + |> JsArray.slice 0 (lastPos + 1) + |> JsArray.unsafeSet lastPos (SubTree newSub) + + -- This is supposed to be the new tail. Fetched by `fetchNewTail`. + -- Slice up to, but not including, this point. + Leaf _ -> + JsArray.slice 0 lastPos tree + {-| The tree is supposed to be of a certain depth. Since slicing removes elements, it could be that the tree should have a smaller depth @@ -809,6 +874,7 @@ hoistTree : Int -> Int -> Tree a -> Tree a hoistTree oldShift newShift tree = if oldShift <= newShift || JsArray.length tree == 0 then tree + else case JsArray.unsafeGet 0 tree of SubTree sub -> @@ -823,24 +889,29 @@ the index of every element after the slice. Which means that we will have to rebuild the array. First, two things are tested: -1. If the array does not need slicing, return the original array. -2. If the slice removes every element but those in the tail, slice the tail and -set the tree to the empty array. + +1. If the array does not need slicing, return the original array. +2. If the slice removes every element but those in the tail, slice the tail and + set the tree to the empty array. Otherwise, we do the following: -1. Add every leaf node in the tree to a list. -2. Drop the nodes which are supposed to be sliced away. -3. Slice the head node of the list, which represents the start of the new array. -4. Create a builder with the tail set as the node from the previous step. -5. Append the remaining nodes into this builder, and create the array. + +1. Add every leaf node in the tree to a list. +2. Drop the nodes which are supposed to be sliced away. +3. Slice the head node of the list, which represents the start of the new array. +4. Create a builder with the tail set as the node from the previous step. +5. Append the remaining nodes into this builder, and create the array. + -} sliceLeft : Int -> Array a -> Array a sliceLeft from ((Array_elm_builtin len _ tree tail) as array) = if from == 0 then array + else if from >= tailIndex len then Array_elm_builtin (len - from) shiftStep JsArray.empty <| JsArray.slice (from - tailIndex len) (JsArray.length tail) tail + else let helper node acc = @@ -860,27 +931,27 @@ sliceLeft from ((Array_elm_builtin len _ tree tail) as array) = nodesToInsert = List.drop skipNodes leafNodes in - case nodesToInsert of - [] -> - empty + case nodesToInsert of + [] -> + empty - head :: rest -> - let - firstSlice = - from - (skipNodes * branchFactor) - - initialBuilder = - { tail = - JsArray.slice - firstSlice - (JsArray.length head) - head - , nodeList = [] - , nodeListSize = 0 - } - in - List.foldl appendHelpBuilder initialBuilder rest - |> builderToArray True + head :: rest -> + let + firstSlice = + from - (skipNodes * branchFactor) + + initialBuilder = + { tail = + JsArray.slice + firstSlice + (JsArray.length head) + head + , nodeList = [] + , nodeListSize = 0 + } + in + List.foldl appendHelpBuilder initialBuilder rest + |> builderToArray True {-| A builder contains all information necessary to build an array. Adding @@ -917,10 +988,10 @@ builderFromArray (Array_elm_builtin len _ tree tail) = Leaf _ -> node :: acc in - { tail = tail - , nodeList = JsArray.foldl helper [] tree - , nodeListSize = len // branchFactor - } + { tail = tail + , nodeList = JsArray.foldl helper [] tree + , nodeListSize = len // branchFactor + } {-| Construct an array with the information in a given builder. @@ -929,6 +1000,7 @@ Due to the nature of `List` the list of nodes in a builder will often be in reverse order (that is, the first leaf of the array is the last node in the node list). This function therefore allows the caller to specify if the node list should be reversed before building the array. + -} builderToArray : Bool -> Builder a -> Array a builderToArray reverseNodeList builder = @@ -938,6 +1010,7 @@ builderToArray reverseNodeList builder = shiftStep JsArray.empty builder.tail + else let treeLen = @@ -952,17 +1025,18 @@ builderToArray reverseNodeList builder = correctNodeList = if reverseNodeList then List.reverse builder.nodeList + else builder.nodeList tree = treeFromBuilder correctNodeList builder.nodeListSize in - Array_elm_builtin - (JsArray.length builder.tail + treeLen) - (max 5 <| depth * shiftStep) - tree - builder.tail + Array_elm_builtin + (JsArray.length builder.tail + treeLen) + (max 5 <| depth * shiftStep) + tree + builder.tail {-| Takes a list of leaves and an `Int` specifying how many leaves there are, @@ -972,16 +1046,17 @@ treeFromBuilder : List (Node a) -> Int -> Tree a treeFromBuilder nodeList nodeListSize = let newNodeSize = - ((toFloat nodeListSize) / (toFloat branchFactor)) + (toFloat nodeListSize / toFloat branchFactor) |> ceiling in - if newNodeSize == 1 then - JsArray.initializeFromList branchFactor nodeList - |> Tuple.first - else - treeFromBuilder - (compressNodes nodeList []) - newNodeSize + if newNodeSize == 1 then + JsArray.initializeFromList branchFactor nodeList + |> Tuple.first + + else + treeFromBuilder + (compressNodes nodeList []) + newNodeSize {-| Takes a list of nodes and return a list of `SubTree`s containing those @@ -994,11 +1069,11 @@ compressNodes nodes acc = JsArray.initializeFromList branchFactor nodes newAcc = - (SubTree node) :: acc + SubTree node :: acc in - case remainingNodes of - [] -> - List.reverse newAcc + case remainingNodes of + [] -> + List.reverse newAcc - _ -> - compressNodes remainingNodes newAcc + _ -> + compressNodes remainingNodes newAcc diff --git a/src/Basics.elm b/src/Basics.elm index 163802cb..5de2b46d 100644 --- a/src/Basics.elm +++ b/src/Basics.elm @@ -1,30 +1,36 @@ module Basics exposing - ( Int, Float - , (+), (-), (*), (/), (//), (^) - , toFloat, round, floor, ceiling, truncate - , (==), (/=) - , (<), (>), (<=), (>=), max, min, compare, Order(..) - , Bool(..), not, (&&), (||), xor - , (++) - , modBy, remainderBy, negate, abs, clamp, sqrt, logBase, e - , pi, cos, sin, tan, acos, asin, atan, atan2 - , degrees, radians, turns - , toPolar, fromPolar - , isNaN, isInfinite - , identity, always, (<|), (|>), (<<), (>>), Never, never - ) + ( Int, Float, (+), (-), (*), (/), (//), (^) + , toFloat, round, floor, ceiling, truncate + , (==), (/=) + , (<), (>), (<=), (>=), max, min, compare, Order(..) + , Bool(..), not, (&&), (||), xor + , (++) + , modBy, remainderBy, negate, abs, clamp, sqrt, logBase, e + , degrees, radians, turns + , pi, cos, sin, tan, acos, asin, atan, atan2 + , toPolar, fromPolar + , isNaN, isInfinite + , identity, always, (<|), (|>), (<<), (>>), Never, never + ) {-| Tons of useful functions that get imported by default. + # Math + @docs Int, Float, (+), (-), (*), (/), (//), (^) + # Int to Float / Float to Int + @docs toFloat, round, floor, ceiling, truncate + # Equality + @docs (==), (/=) + # Comparison These functions only work on `comparable` types. This includes numbers, @@ -33,33 +39,48 @@ things. @docs (<), (>), (<=), (>=), max, min, compare, Order + # Booleans + @docs Bool, not, (&&), (||), xor + # Append Strings and Lists + @docs (++) + # Fancier Math + @docs modBy, remainderBy, negate, abs, clamp, sqrt, logBase, e + # Angles + @docs degrees, radians, turns + # Trigonometry + @docs pi, cos, sin, tan, acos, asin, atan, atan2 + # Polar Coordinates + @docs toPolar, fromPolar + # Floating Point Checks + @docs isNaN, isInfinite + # Function Helpers + @docs identity, always, (<|), (|>), (<<), (>>), Never, never -} - import Elm.Kernel.Basics import Elm.Kernel.Utils @@ -74,17 +95,17 @@ infix right 2 (||) = or infix right 3 (&&) = and infix non 4 (==) = eq infix non 4 (/=) = neq -infix non 4 (<) = lt -infix non 4 (>) = gt +infix non 4 (<) = lt +infix non 4 (>) = gt infix non 4 (<=) = le infix non 4 (>=) = ge infix right 5 (++) = append -infix left 6 (+) = add -infix left 6 (-) = sub -infix left 7 (*) = mul -infix left 7 (/) = fdiv +infix left 6 (+) = add +infix left 6 (-) = sub +infix left 7 (*) = mul +infix left 7 (/) = fdiv infix left 7 (//) = idiv -infix right 8 (^) = pow +infix right 8 (^) = pow infix left 9 (<<) = composeL infix right 9 (>>) = composeR @@ -96,10 +117,14 @@ infix right 9 (>>) = composeR {-| An `Int` is a whole number. Valid syntax for integers includes: 0 + 42 + 9000 - 0xFF -- 255 in hexadecimal - 0x000A -- 10 in hexadecimal + + 0xFF -- 255 in hexadecimal + + 0x0A -- 10 in hexadecimal **Note:** `Int` math is well-defined in the range `-2^31` to `2^31 - 1`. Outside of that range, the behavior is determined by the compilation target. When @@ -108,7 +133,7 @@ operations, but if we generate WebAssembly some day, we would do the traditional [integer overflow][io]. This quirk is necessary to get good performance on quirky compilation targets. -**Historical Note:** The name `Int` comes from the term [integer][]. It appears +**Historical Note:** The name `Int` comes from the term [integer]. It appears that the `int` abbreviation was introduced in [ALGOL 68][68], shortening it from `integer` in [ALGOL 60][60]. Today, almost all programming languages use this abbreviation. @@ -117,8 +142,10 @@ this abbreviation. [integer]: https://en.wikipedia.org/wiki/Integer [60]: https://en.wikipedia.org/wiki/ALGOL_60 [68]: https://en.wikipedia.org/wiki/ALGOL_68 + -} -type Int = Int -- NOTE: The compiler provides the real implementation. +type Int + = Int -- NOTE: The compiler provides the real implementation. {-| A `Float` is a [floating-point number][fp]. Valid syntax for floats includes: @@ -140,115 +167,149 @@ compatible with any widely-used assembly language. [fp]: https://en.wikipedia.org/wiki/Floating-point_arithmetic [ieee]: https://en.wikipedia.org/wiki/IEEE_754 + -} -type Float = Float -- NOTE: The compiler provides the real implementation. +type Float + = Float -- NOTE: The compiler provides the real implementation. {-| Add two numbers. The `number` type variable means this operation can be specialized to `Int -> Int -> Int` or to `Float -> Float -> Float`. So you can do things like this: - 3002 + 4004 == 7006 -- all ints - 3.14 + 3.14 == 6.28 -- all floats + 3002 + 4004 == 7006 -- all ints + + 3.14 + 3.14 == 6.28 -- all floats You _cannot_ add an `Int` and a `Float` directly though. Use functions like [toFloat](#toFloat) or [round](#round) to convert both values to the same type. So if you needed to add a list length to a `Float` for some reason, you could say one of these: - 3.14 + toFloat (List.length [1,2,3]) == 6.14 - round 3.14 + List.length [1,2,3] == 6 + 3.14 + toFloat (List.length [ 1, 2, 3 ]) == 6.14 + + round 3.14 + List.length [ 1, 2, 3 ] == 6 **Note:** Languages like Java and JavaScript automatically convert `Int` values to `Float` values when you mix and match. This can make it difficult to be sure exactly what type of number you are dealing with. When you try to _infer_ these conversions (as Scala does) it can be even more confusing. Elm has opted for a design that makes all conversions explicit. + -} add : number -> number -> number add lhs rhs = - let - sum = add lhs rhs - in + let + sum = + add lhs rhs + in sum {-| Subtract numbers like `4 - 3 == 1`. See [`(+)`](#+) for docs on the `number` type variable. + -} sub : number -> number -> number sub lhs rhs = - let - difference = sub lhs rhs - in + let + difference = + sub lhs rhs + in difference {-| Multiply numbers like `2 * 3 == 6`. See [`(+)`](#+) for docs on the `number` type variable. + -} mul : number -> number -> number mul lhs rhs = - let - product = mul lhs rhs - in + let + product = + mul lhs rhs + in product + {-| Floating-point division: 10 / 4 == 2.5 + 11 / 4 == 2.75 + 12 / 4 == 3 + 13 / 4 == 3.25 - 14 / 4 == 3.5 - -1 / 4 == -0.25 - -5 / 4 == -1.25 + 14 + / 4 + == 3.5 + - 1 + / 4 + == -0.25 + - 5 + / 4 + == -1.25 -} fdiv : Float -> Float -> Float fdiv lhs rhs = - let - quotient = fdiv lhs rhs - in + let + quotient = + fdiv lhs rhs + in quotient {-| Integer division: 10 // 4 == 2 + 11 // 4 == 2 + 12 // 4 == 3 + 13 // 4 == 3 - 14 // 4 == 3 - -1 // 4 == 0 - -5 // 4 == -1 + 14 + // 4 + == 3 + - 1 + // 4 + == 0 + - 5 + // 4 + == -1 Notice that the remainder is discarded, so `3 // 4` is giving output similar to `truncate (3 / 4)`. It may sometimes be useful to pair this with the [`remainderBy`](#remainderBy) function. + -} idiv : Int -> Int -> Int idiv lhs rhs = - let - quotient = idiv lhs rhs - in + let + quotient = + idiv lhs rhs + in quotient {-| Exponentiation - 3^2 == 9 - 3^3 == 27 + 3 ^ 2 == 9 + + 3 ^ 3 == 27 + -} pow : number -> number -> number pow base exponent = - Elm.Kernel.Basics.pow base exponent + Elm.Kernel.Basics.pow base exponent @@ -260,81 +321,107 @@ values like this: halfOf : Int -> Float halfOf number = - toFloat number / 2 + toFloat number / 2 -} toFloat : Int -> Float toFloat x = - let - asFloat = toFloat x - in + let + asFloat = + toFloat x + in asFloat {-| Round a number to the nearest integer. round 1.0 == 1 + round 1.2 == 1 + round 1.5 == 2 + round 1.8 == 2 round -1.2 == -1 + round -1.5 == -1 + round -1.8 == -2 + -} round : Float -> Int round = - Elm.Kernel.Basics.round + Elm.Kernel.Basics.round {-| Floor function, rounding down. floor 1.0 == 1 + floor 1.2 == 1 + floor 1.5 == 1 + floor 1.8 == 1 floor -1.2 == -2 + floor -1.5 == -2 + floor -1.8 == -2 + -} floor : Float -> Int floor = - Elm.Kernel.Basics.floor + Elm.Kernel.Basics.floor {-| Ceiling function, rounding up. ceiling 1.0 == 1 + ceiling 1.2 == 2 + ceiling 1.5 == 2 + ceiling 1.8 == 2 ceiling -1.2 == -1 + ceiling -1.5 == -1 + ceiling -1.8 == -1 + -} ceiling : Float -> Int ceiling = - Elm.Kernel.Basics.ceiling + Elm.Kernel.Basics.ceiling {-| Truncate a number, rounding towards zero. truncate 1.0 == 1 + truncate 1.2 == 1 + truncate 1.5 == 1 + truncate 1.8 == 1 truncate -1.2 == -1 + truncate -1.5 == -1 + truncate -1.8 == -1 + -} truncate : Float -> Int truncate x = - let - truncated = truncate x - in + let + truncated = + truncate x + in truncated @@ -355,7 +442,7 @@ possible. With JSON values, decode to Elm values before doing any equality checks! Why is it like this? Equality in the Elm sense can be difficult or impossible -to compute. Proving that functions are the same is [undecidable][], and JSON +to compute. Proving that functions are the same is [undecidable], and JSON values can come in through ports and have functions, cycles, and new JS data types that interact weirdly with our equality implementation. In a future release, the compiler will detect when `(==)` is used with problematic types @@ -364,24 +451,28 @@ pretty serious infrastructure work, so the stopgap is to crash as quickly as possible. [undecidable]: https://en.wikipedia.org/wiki/Undecidable_problem + -} eq : a -> a -> Bool eq lhs rhs = - let - areEqual = eq lhs rhs - in + let + areEqual = + eq lhs rhs + in areEqual {-| Check if values are not “the same”. So `(a /= b)` is the same as `(not (a == b))`. + -} neq : a -> a -> Bool neq lhs rhs = - let - areNotEqual = neq lhs rhs - in + let + areNotEqual = + neq lhs rhs + in areNotEqual @@ -389,60 +480,76 @@ neq lhs rhs = -- COMPARISONS -{-|-} +{-| -} lt : comparable -> comparable -> Bool lt lhs rhs = - let - lhsSmaller = lt lhs rhs - in + let + lhsSmaller = + lt lhs rhs + in lhsSmaller -{-|-} +{-| -} gt : comparable -> comparable -> Bool gt lhs rhs = - let - lhsLarger = gt lhs rhs - in + let + lhsLarger = + gt lhs rhs + in lhsLarger -{-|-} +{-| -} le : comparable -> comparable -> Bool le lhs rhs = - let - lhsSmallerOrEqual = le lhs rhs - in + let + lhsSmallerOrEqual = + le lhs rhs + in lhsSmallerOrEqual -{-|-} +{-| -} ge : comparable -> comparable -> Bool ge lhs rhs = - let - lhsLargerOrEqual = ge lhs rhs - in + let + lhsLargerOrEqual = + ge lhs rhs + in lhsLargerOrEqual {-| Find the smaller of two comparables. min 42 12345678 == 42 + min "abc" "xyz" == "abc" + -} min : comparable -> comparable -> comparable min x y = - if lt x y then x else y + if lt x y then + x + + else + y {-| Find the larger of two comparables. max 42 12345678 == 12345678 + max "abc" "xyz" == "xyz" + -} max : comparable -> comparable -> comparable max x y = - if gt x y then x else y + if gt x y then + x + + else + y {-| Compare any two comparable values. Comparable values include `String`, @@ -450,18 +557,24 @@ max x y = are also the only values that work as `Dict` keys or `Set` members. compare 3 4 == LT + compare 4 4 == EQ + compare 5 4 == GT + -} compare : comparable -> comparable -> Order compare = - Elm.Kernel.Utils.compare + Elm.Kernel.Utils.compare {-| Represents the relative ordering of two things. The relations are less than, equal to, and greater than. -} -type Order = LT | EQ | GT +type Order + = LT + | EQ + | GT @@ -478,73 +591,94 @@ from Richard [here][rt]. [ut]: https://guide.elm-lang.org/types/union_types.html [jf]: https://youtu.be/6TDKHGtAxeg?t=1m25s [rt]: https://youtu.be/IcgmSRJHu_8?t=1m14s + -} -type Bool = True | False +type Bool + = True + | False {-| Negate a boolean value. not True == False + not False == True + -} not : Bool -> Bool not x = - let - complement = not x - in + let + complement = + not x + in complement {-| The logical AND operator. `True` if both inputs are `True`. - True && True == True - True && False == False - False && True == False + True && True == True + + True && False == False + + False && True == False + False && False == False **Note:** When used in the infix position, like `(left && right)`, the operator short-circuits. This means if `left` is `False` we do not bother evaluating `right` and just return `False` overall. + -} and : Bool -> Bool -> Bool and lhs rhs = - let - areBothTrue = and lhs rhs - in + let + areBothTrue = + and lhs rhs + in areBothTrue {-| The logical OR operator. `True` if one or both inputs are `True`. - True || True == True - True || False == True - False || True == True + True || True == True + + True || False == True + + False || True == True + False || False == False **Note:** When used in the infix position, like `(left || right)`, the operator short-circuits. This means if `left` is `True` we do not bother evaluating `right` and just return `True` overall. + -} or : Bool -> Bool -> Bool or lhs rhs = - let - areEitherTrue = or lhs rhs - in + let + areEitherTrue = + or lhs rhs + in areEitherTrue {-| The exclusive-or operator. `True` if exactly one input is `True`. - xor True True == False - xor True False == True - xor False True == True + xor True True == False + + xor True False == True + + xor False True == True + xor False False == False + -} xor : Bool -> Bool -> Bool xor lhs rhs = - let - isOneTrue = xor lhs rhs - in + let + isOneTrue = + xor lhs rhs + in isOneTrue @@ -555,13 +689,16 @@ xor lhs rhs = {-| Put two appendable things together. This includes strings and lists. "hello" ++ "world" == "helloworld" - [1,1,2] ++ [3,5,8] == [1,1,2,3,5,8] + + [ 1, 1, 2 ] ++ [ 3, 5, 8 ] == [ 1, 1, 2, 3, 5, 8 ] + -} append : appendable -> appendable -> appendable append lhs rhs = - let - appended = append lhs rhs - in + let + appended = + append lhs rhs + in appended @@ -573,8 +710,11 @@ append lhs rhs = A common trick is to use (n mod 2) to detect even and odd numbers: modBy 2 0 == 0 + modBy 2 1 == 1 + modBy 2 2 == 0 + modBy 2 3 == 1 Our `modBy` function works in the typical mathematical way when you run into @@ -588,66 +728,82 @@ or read Daan Leijen’s [Division and Modulus for Computer Scientists][dm] for m information. [dm]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf + -} modBy : Int -> Int -> Int modBy modulus x = - let - answer = - remainderBy modulus x - in + let + answer = + remainderBy modulus x + in if eq modulus 0 then - Elm.Kernel.Basics.modBy0 () + Elm.Kernel.Basics.modBy0 () + else if or (and (gt answer 0) (lt modulus 0)) (and (lt answer 0) (gt modulus 0)) then - add answer modulus + add answer modulus + else - answer + answer {-| Get the remainder after division. Here are bunch of examples of dividing by four: - List.map (remainderBy 4) [ -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 ] - -- [ -1, 0, -3, -2, -1, 0, 1, 2, 3, 0, 1 ] +List.map (remainderBy 4) [ -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 ][ -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 ] +-- [ -1, 0, -3, -2, -1, 0, 1, 2, 3, 0, 1 ][ -1, 0, -3, -2, -1, 0, 1, 2, 3, 0, 1 ] Use [`modBy`](#modBy) for a different treatment of negative numbers, or read Daan Leijen’s [Division and Modulus for Computer Scientists][dm] for more information. [dm]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf + -} remainderBy : Int -> Int -> Int remainderBy divisor dividend = - let - remainder = remainderBy divisor dividend - in + let + remainder = + remainderBy divisor dividend + in remainder {-| Negate a number. negate 42 == -42 + negate -42 == 42 + negate 0 == 0 + -} negate : number -> number negate x = - let - negated = negate x - in + let + negated = + negate x + in negated - {-| Get the [absolute value][abs] of a number. - abs 16 == 16 - abs -4 == 4 + abs 16 == 16 + + abs -4 == 4 + abs -8.5 == 8.5 + abs 3.14 == 3.14 [abs]: https://en.wikipedia.org/wiki/Absolute_value + -} abs : number -> number abs n = - if lt n 0 then -n else n + if lt n 0 then + -n + + else + n {-| Clamps a number within a given range. With the expression @@ -656,46 +812,55 @@ abs n = 100 if x < 100 x if 100 <= x < 200 200 if 200 <= x + -} clamp : number -> number -> number -> number clamp low high number = - if lt number low then - low - else if gt number high then - high - else - number + if lt number low then + low + + else if gt number high then + high + + else + number {-| Take the square root of a number. - sqrt 4 == 2 - sqrt 9 == 3 + sqrt 4 == 2 + + sqrt 9 == 3 + sqrt 16 == 4 + sqrt 25 == 5 + -} sqrt : Float -> Float sqrt = - Elm.Kernel.Basics.sqrt + Elm.Kernel.Basics.sqrt {-| Calculate the logarithm of a number with a given base. logBase 10 100 == 2 + logBase 2 256 == 8 + -} logBase : Float -> Float -> Float logBase base number = - fdiv - (Elm.Kernel.Basics.log number) - (Elm.Kernel.Basics.log base) + fdiv + (Elm.Kernel.Basics.log number) + (Elm.Kernel.Basics.log base) {-| An approximation of e. -} e : Float e = - 2.7182818284590452353602874713526624977572470 + 2.718281828459045 @@ -705,28 +870,31 @@ e = {-| Convert radians to standard Elm angles (radians). radians pi == 3.141592653589793 + -} radians : Float -> Float radians angleInRadians = - angleInRadians + angleInRadians {-| Convert degrees to standard Elm angles (radians). degrees 180 == 3.141592653589793 + -} degrees : Float -> Float degrees angleInDegrees = - fdiv (mul angleInDegrees pi) 180 + fdiv (mul angleInDegrees pi) 180 {-| Convert turns to standard Elm angles (radians). One turn is equal to 360°. - turns (1/2) == 3.141592653589793 + turns (1 / 2) == 3.141592653589793 + -} turns : Float -> Float turns angleInTurns = - mul (mul 2 pi) angleInTurns + mul (mul 2 pi) angleInTurns @@ -737,65 +905,75 @@ turns angleInTurns = -} pi : Float pi = - 3.14159265358979323851280895 + 3.141592653589793 {-| Figure out the cosine given an angle in radians. - cos (degrees 60) == 0.5000000000000001 - cos (turns (1/6)) == 0.5000000000000001 - cos (radians (pi/3)) == 0.5000000000000001 - cos (pi/3) == 0.5000000000000001 + cos (degrees 60) == 0.5000000000000001 + + cos (turns (1 / 6)) == 0.5000000000000001 + + cos (radians (pi / 3)) == 0.5000000000000001 + + cos (pi / 3) == 0.5000000000000001 -} cos : Float -> Float cos = - Elm.Kernel.Basics.cos + Elm.Kernel.Basics.cos {-| Figure out the sine given an angle in radians. - sin (degrees 30) == 0.49999999999999994 - sin (turns (1/12)) == 0.49999999999999994 - sin (radians (pi/6)) == 0.49999999999999994 - sin (pi/6) == 0.49999999999999994 + sin (degrees 30) == 0.49999999999999994 + + sin (turns (1 / 12)) == 0.49999999999999994 + + sin (radians (pi / 6)) == 0.49999999999999994 + + sin (pi / 6) == 0.49999999999999994 -} sin : Float -> Float sin = - Elm.Kernel.Basics.sin + Elm.Kernel.Basics.sin {-| Figure out the tangent given an angle in radians. - tan (degrees 45) == 0.9999999999999999 - tan (turns (1/8)) == 0.9999999999999999 - tan (radians (pi/4)) == 0.9999999999999999 - tan (pi/4) == 0.9999999999999999 + tan (degrees 45) == 0.9999999999999999 + + tan (turns (1 / 8)) == 0.9999999999999999 + + tan (radians (pi / 4)) == 0.9999999999999999 + + tan (pi / 4) == 0.9999999999999999 + -} tan : Float -> Float tan = - Elm.Kernel.Basics.tan + Elm.Kernel.Basics.tan {-| Figure out the arccosine for `adjacent / hypotenuse` in radians: - acos (1/2) == 1.0471975511965979 -- 60° or pi/3 radians + acos (1 / 2) == 1.0471975511965979 -- 60° or pi/3 radians -} acos : Float -> Float acos = - Elm.Kernel.Basics.acos + Elm.Kernel.Basics.acos {-| Figure out the arcsine for `opposite / hypotenuse` in radians: - asin (1/2) == 0.5235987755982989 -- 30° or pi/6 radians + asin (1 / 2) == 0.5235987755982989 -- 30° or pi/6 radians -} asin : Float -> Float asin = - Elm.Kernel.Basics.asin + Elm.Kernel.Basics.asin {-| This helps you find the angle (in radians) to an `(x,y)` coordinate, but @@ -807,33 +985,40 @@ the negative signs comes from the `y` or `x` value. So as we go counter-clockwis around the origin from point `(1,1)` to `(1,-1)` to `(-1,-1)` to `(-1,1)` we do not get angles that go in the full circle: - atan ( 1 / 1 ) == 0.7853981633974483 -- 45° or pi/4 radians - atan ( 1 / -1 ) == -0.7853981633974483 -- 315° or 7*pi/4 radians - atan ( -1 / -1 ) == 0.7853981633974483 -- 45° or pi/4 radians - atan ( -1 / 1 ) == -0.7853981633974483 -- 315° or 7*pi/4 radians + atan (1 / 1) == 0.7853981633974483 -- 45° or pi/4 radians + + atan (1 / -1) == -0.7853981633974483 -- 315° or 7*pi/4 radians + + atan (-1 / -1) == 0.7853981633974483 -- 45° or pi/4 radians + + atan (-1 / 1) == -0.7853981633974483 -- 315° or 7*pi/4 radians Notice that everything is between `pi/2` and `-pi/2`. That is pretty useless for figuring out angles in any sort of visualization, so again, check out [`atan2`](#atan2) instead! + -} atan : Float -> Float atan = - Elm.Kernel.Basics.atan + Elm.Kernel.Basics.atan {-| This helps you find the angle (in radians) to an `(x,y)` coordinate. So rather than saying `atan (y/x)` you say `atan2 y x` and you can get a full range of angles: - atan2 1 1 == 0.7853981633974483 -- 45° or pi/4 radians - atan2 1 -1 == 2.356194490192345 -- 135° or 3*pi/4 radians - atan2 -1 -1 == -2.356194490192345 -- 225° or 5*pi/4 radians - atan2 -1 1 == -0.7853981633974483 -- 315° or 7*pi/4 radians + atan2 1 1 == 0.7853981633974483 -- 45° or pi/4 radians + + atan2 1 -1 == 2.356194490192345 -- 135° or 3*pi/4 radians + + atan2 -1 -1 == -2.356194490192345 -- 225° or 5*pi/4 radians + + atan2 -1 1 == -0.7853981633974483 -- 315° or 7*pi/4 radians -} atan2 : Float -> Float -> Float atan2 = - Elm.Kernel.Basics.atan2 + Elm.Kernel.Basics.atan2 @@ -842,25 +1027,28 @@ atan2 = {-| Convert polar coordinates (r,θ) to Cartesian coordinates (x,y). - fromPolar (sqrt 2, degrees 45) == (1, 1) + fromPolar ( sqrt 2, degrees 45 ) == ( 1, 1 ) + -} -fromPolar : (Float,Float) -> (Float,Float) -fromPolar (radius, theta) = - ( mul radius (cos theta) - , mul radius (sin theta) - ) +fromPolar : ( Float, Float ) -> ( Float, Float ) +fromPolar ( radius, theta ) = + ( mul radius (cos theta) + , mul radius (sin theta) + ) {-| Convert Cartesian coordinates (x,y) to polar coordinates (r,θ). - toPolar (3, 4) == ( 5, 0.9272952180016122) - toPolar (5,12) == (13, 1.1760052070951352) + toPolar ( 3, 4 ) == ( 5, 0.9272952180016122 ) + + toPolar ( 5, 12 ) == ( 13, 1.1760052070951352 ) + -} -toPolar : (Float,Float) -> (Float,Float) +toPolar : ( Float, Float ) -> ( Float, Float ) toPolar ( x, y ) = - ( sqrt (add (mul x x) (mul y y)) - , atan2 y x - ) + ( sqrt (add (mul x x) (mul y y)) + , atan2 y x + ) @@ -868,32 +1056,40 @@ toPolar ( x, y ) = {-| Determine whether a float is an undefined or unrepresentable number. -NaN stands for *not a number* and it is [a standardized part of floating point +NaN stands for _not a number_ and it is [a standardized part of floating point numbers](https://en.wikipedia.org/wiki/NaN). - isNaN (0/0) == True + isNaN (0 / 0) == True + isNaN (sqrt -1) == True - isNaN (1/0) == False -- infinity is a number - isNaN 1 == False + + isNaN (1 / 0) == False -- infinity is a number + + isNaN 1 == False + -} isNaN : Float -> Bool isNaN n = - neq n n + neq n n {-| Determine whether a float is positive or negative infinity. - isInfinite (0/0) == False + isInfinite (0 / 0) == False + isInfinite (sqrt -1) == False - isInfinite (1/0) == True - isInfinite 1 == False + + isInfinite (1 / 0) == True + + isInfinite 1 == False Notice that NaN is not infinite! For float `n` to be finite implies that `not (isInfinite n || isNaN n)` evaluates to `True`. + -} isInfinite : Float -> Bool isInfinite n = - eq (abs n) (fdiv 1 0) + eq (abs n) (fdiv 1 0) @@ -907,15 +1103,16 @@ example, the following code checks if the square root of a number is odd: You can think of this operator as equivalent to the following: - (g << f) == (\x -> g (f x)) + (g << f) == (\x -> g (f x)) So our example expands out to something like this: \n -> not (isEven (sqrt n)) + -} composeL : (b -> c) -> (a -> b) -> (a -> c) composeL g f x = - g (f x) + g (f x) {-| Function composition, passing results along in the suggested direction. For @@ -926,7 +1123,7 @@ example, the following code checks if the square root of a number is odd: -} composeR : (a -> b) -> (b -> c) -> (a -> c) composeR f g x = - g (f x) + g (f x) {-| Saying `x |> f` is exactly the same as `f x`. @@ -938,16 +1135,16 @@ integers: -- BEFORE sanitize : String -> Maybe Int sanitize input = - String.toInt (String.trim input) + String.toInt (String.trim input) We can rewrite it like this: -- AFTER sanitize : String -> Maybe Int sanitize input = - input - |> String.trim - |> String.toInt + input + |> String.trim + |> String.toInt Totally equivalent! I recommend trying to rewrite code that uses `x |> f` into code like `f x` until there are no pipes left. That can help you build @@ -958,12 +1155,14 @@ have three or four steps, the code often gets clearer if you break out a top-level helper function. Now the transformation has a name. The arguments are named. It has a type annotation. It is much more self-documenting that way! Testing the logic gets easier too. Nice side benefit! + -} apR : a -> (a -> b) -> b apR x f = - let - applied = apR x f - in + let + applied = + apR x f + in applied @@ -971,12 +1170,14 @@ apR x f = It can help you avoid parentheses, which can be nice sometimes. Maybe you want to apply a function to a `case` expression? That sort of thing. + -} apL : (a -> b) -> a -> b apL f x = - let - applied = apL f x - in + let + applied = + apL f x + in applied @@ -985,20 +1186,21 @@ apL f x = -} identity : a -> a identity x = - x + x -{-| Create a function that *always* returns the same value. Useful with +{-| Create a function that _always_ returns the same value. Useful with functions like `map`: List.map (always 0) [1,2,3,4,5] == [0,0,0,0,0] -- List.map (\_ -> 0) [1,2,3,4,5] == [0,0,0,0,0] -- always = (\x _ -> x) + -} always : a -> b -> a always a _ = - a + a {-| A value that can never happen! For context: @@ -1014,31 +1216,34 @@ So there cannot be any event handlers on that HTML. You may also see this used with tasks that never fail, like `Task Never ()`. -The `Never` type is useful for restricting *arguments* to a function. Maybe my +The `Never` type is useful for restricting _arguments_ to a function. Maybe my API can only accept HTML without event handlers, so I require `Html Never` and users can give `Html msg` and everything will go fine. Generally speaking, you do not want `Never` in your return types though. + -} -type Never = JustOneMore Never +type Never + = JustOneMore Never {-| A function that can never be called. Seems extremely pointless, but it -*can* come in handy. Imagine you have some HTML that should never produce any -messages. And say you want to use it in some other HTML that *does* produce +_can_ come in handy. Imagine you have some HTML that should never produce any +messages. And say you want to use it in some other HTML that _does_ produce messages. You could say: import Html exposing (..) embedHtml : Html Never -> Html msg embedHtml staticStuff = - div [] - [ text "hello" - , Html.map never staticStuff - ] + div [] + [ text "hello" + , Html.map never staticStuff + ] So the `never` function is basically telling the type system, make sure no one ever calls me! + -} never : Never -> a never (JustOneMore nvr) = - never nvr + never nvr diff --git a/src/Bitwise.elm b/src/Bitwise.elm index 9c49f6bc..fbc4a4b9 100644 --- a/src/Bitwise.elm +++ b/src/Bitwise.elm @@ -1,29 +1,33 @@ module Bitwise exposing - ( and, or, xor, complement - , shiftLeftBy, shiftRightBy, shiftRightZfBy - ) + ( and, or, xor, complement + , shiftLeftBy, shiftRightBy, shiftRightZfBy + ) {-| Library for [bitwise operations](https://en.wikipedia.org/wiki/Bitwise_operation). + # Basic Operations + @docs and, or, xor, complement + # Bit Shifts + @docs shiftLeftBy, shiftRightBy, shiftRightZfBy --} +-} import Basics exposing (Int) - {-| Bitwise AND -} and : Int -> Int -> Int and lhs rhs = - let - res = and lhs rhs - in + let + res = + and lhs rhs + in res @@ -31,53 +35,59 @@ and lhs rhs = -} or : Int -> Int -> Int or lhs rhs = - let - res = or lhs rhs - in + let + res = + or lhs rhs + in res - {-| Bitwise XOR -} xor : Int -> Int -> Int xor lhs rhs = - let - res = xor lhs rhs - in + let + res = + xor lhs rhs + in res - {-| Flip each bit individually, often called bitwise NOT -} complement : Int -> Int complement x = - let - res = complement x - in + let + res = + complement x + in res + {-| Shift bits to the left by a given offset, filling new bits with zeros. This can be used to multiply numbers by powers of two. shiftLeftBy 1 5 == 10 + shiftLeftBy 5 1 == 32 + -} shiftLeftBy : Int -> Int -> Int shiftLeftBy lhs rhs = - let - res = shiftLeftBy lhs rhs - in + let + res = + shiftLeftBy lhs rhs + in res - {-| Shift bits to the right by a given offset, filling new bits with whatever is the topmost bit. This can be used to divide numbers by powers of two. - shiftRightBy 1 32 == 16 - shiftRightBy 2 32 == 8 + shiftRightBy 1 32 == 16 + + shiftRightBy 2 32 == 8 + shiftRightBy 1 -32 == -16 This is called an [arithmetic right shift][ars], often written `>>`, and @@ -85,20 +95,23 @@ sometimes called a sign-propagating right shift because it fills empty spots with copies of the highest bit. [ars]: https://en.wikipedia.org/wiki/Bitwise_operation#Arithmetic_shift + -} shiftRightBy : Int -> Int -> Int shiftRightBy lhs rhs = - let - res = shiftRightBy lhs rhs - in + let + res = + shiftRightBy lhs rhs + in res - {-| Shift bits to the right by a given offset, filling new bits with zeros. - shiftRightZfBy 1 32 == 16 - shiftRightZfBy 2 32 == 8 + shiftRightZfBy 1 32 == 16 + + shiftRightZfBy 2 32 == 8 + shiftRightZfBy 1 -32 == 2147483632 This is called an [logical right shift][lrs], often written `>>>`, and @@ -106,11 +119,12 @@ sometimes called a zero-fill right shift because it fills empty spots with zeros. [lrs]: https://en.wikipedia.org/wiki/Bitwise_operation#Logical_shift + -} shiftRightZfBy : Int -> Int -> Int shiftRightZfBy lhs rhs = - let - res = shiftRightZfBy lhs rhs - in + let + res = + shiftRightZfBy lhs rhs + in res - diff --git a/src/Char.elm b/src/Char.elm index 059c75a5..c3adac64 100644 --- a/src/Char.elm +++ b/src/Char.elm @@ -1,31 +1,42 @@ module Char exposing - ( Char - , isUpper, isLower, isAlpha, isAlphaNum - , isDigit, isOctDigit, isHexDigit - , toUpper, toLower, toLocaleUpper, toLocaleLower - , toCode, fromCode - ) + ( Char + , isUpper, isLower, isAlpha, isAlphaNum + , isDigit, isOctDigit, isHexDigit + , toUpper, toLower, toLocaleUpper, toLocaleLower + , toCode, fromCode + ) {-| Functions for working with characters. Character literals are enclosed in `'a'` pair of single quotes. + # Characters + @docs Char + # ASCII Letters + @docs isUpper, isLower, isAlpha, isAlphaNum + # Digits + @docs isDigit, isOctDigit, isHexDigit + # Conversion + @docs toUpper, toLower, toLocaleUpper, toLocaleLower + # Unicode Code Points + @docs toCode, fromCode + -} -import Basics exposing (Bool, Int, (&&), (||), (>=), (<=)) +import Basics exposing ((&&), (<=), (>=), (||), Bool, Int) import Elm.Kernel.Char @@ -36,17 +47,26 @@ import Elm.Kernel.Char {-| A `Char` is a single [unicode][u] character: 'a' + '0' + 'Z' + '?' + '"' + 'Σ' + '🙈' '\t' - '\"' + + '"' + '\'' - '\u{1F648}' -- '🙈' + + '🙈' -- '🙈' **Note 1:** You _cannot_ use single quotes around multiple characters like in JavaScript. This is how we distinguish [`String`](String#String) and `Char` @@ -58,8 +78,10 @@ characters directly. Using the escapes can be better if you need one of the many whitespace characters with different widths. [u]: https://en.wikipedia.org/wiki/Unicode + -} -type Char = Char -- NOTE: The compiler provides the real implementation. +type Char + = Char -- NOTE: The compiler provides the real implementation. @@ -69,115 +91,150 @@ type Char = Char -- NOTE: The compiler provides the real implementation. {-| Detect upper case ASCII characters. isUpper 'A' == True - isUpper 'B' == True - ... - isUpper 'Z' == True + + isUpper 'B' + == True + ... isUpper 'Z' + == True isUpper '0' == False + isUpper 'a' == False + isUpper '-' == False + isUpper 'Σ' == False + -} isUpper : Char -> Bool isUpper char = - let - code = - toCode char - in + let + code = + toCode char + in code <= 0x5A && 0x41 <= code {-| Detect lower case ASCII characters. isLower 'a' == True - isLower 'b' == True - ... - isLower 'z' == True + + isLower 'b' + == True + ... isLower 'z' + == True isLower '0' == False + isLower 'A' == False + isLower '-' == False + isLower 'π' == False + -} isLower : Char -> Bool isLower char = - let - code = - toCode char - in + let + code = + toCode char + in 0x61 <= code && code <= 0x7A {-| Detect upper case and lower case ASCII characters. isAlpha 'a' == True + isAlpha 'b' == True + isAlpha 'E' == True + isAlpha 'Y' == True isAlpha '0' == False + isAlpha '-' == False + isAlpha 'π' == False + -} isAlpha : Char -> Bool isAlpha char = - isLower char || isUpper char + isLower char || isUpper char {-| Detect upper case and lower case ASCII characters. isAlphaNum 'a' == True + isAlphaNum 'b' == True + isAlphaNum 'E' == True + isAlphaNum 'Y' == True + isAlphaNum '0' == True + isAlphaNum '7' == True isAlphaNum '-' == False + isAlphaNum 'π' == False + -} isAlphaNum : Char -> Bool isAlphaNum char = - isLower char || isUpper char || isDigit char + isLower char || isUpper char || isDigit char {-| Detect digits `0123456789` isDigit '0' == True - isDigit '1' == True - ... - isDigit '9' == True + + isDigit '1' + == True + ... isDigit '9' + == True isDigit 'a' == False + isDigit 'b' == False + isDigit 'A' == False + -} isDigit : Char -> Bool isDigit char = - let - code = - toCode char - in + let + code = + toCode char + in code <= 0x39 && 0x30 <= code {-| Detect octal digits `01234567` isOctDigit '0' == True - isOctDigit '1' == True - ... - isOctDigit '7' == True + + isOctDigit '1' + == True + ... isOctDigit '7' + == True isOctDigit '8' == False + isOctDigit 'a' == False + isOctDigit 'A' == False + -} isOctDigit : Char -> Bool isOctDigit char = - let - code = - toCode char - in + let + code = + toCode char + in code <= 0x37 && 0x30 <= code @@ -185,41 +242,45 @@ isOctDigit char = -} isHexDigit : Char -> Bool isHexDigit char = - let - code = - toCode char - in + let + code = + toCode char + in (0x30 <= code && code <= 0x39) - || (0x41 <= code && code <= 0x46) - || (0x61 <= code && code <= 0x66) + || (0x41 <= code && code <= 0x46) + || (0x61 <= code && code <= 0x66) -- CONVERSIONS -{-| Convert to upper case. -} +{-| Convert to upper case. +-} toUpper : Char -> Char toUpper = - Elm.Kernel.Char.toUpper + Elm.Kernel.Char.toUpper -{-| Convert to lower case. -} +{-| Convert to lower case. +-} toLower : Char -> Char toLower = - Elm.Kernel.Char.toLower + Elm.Kernel.Char.toLower -{-| Convert to upper case, according to any locale-specific case mappings. -} +{-| Convert to upper case, according to any locale-specific case mappings. +-} toLocaleUpper : Char -> Char toLocaleUpper = - Elm.Kernel.Char.toLocaleUpper + Elm.Kernel.Char.toLocaleUpper -{-| Convert to lower case, according to any locale-specific case mappings. -} +{-| Convert to lower case, according to any locale-specific case mappings. +-} toLocaleLower : Char -> Char toLocaleLower = - Elm.Kernel.Char.toLocaleLower + Elm.Kernel.Char.toLocaleLower {-| Convert to the corresponding Unicode [code point][cp]. @@ -227,31 +288,42 @@ toLocaleLower = [cp]: https://en.wikipedia.org/wiki/Code_point toCode 'A' == 65 + toCode 'B' == 66 + toCode '木' == 0x6728 - toCode '𝌆' == 0x1D306 - toCode '😃' == 0x1F603 + + toCode '𝌆' == 0x0001D306 + + toCode '😃' == 0x0001F603 + -} toCode : Char -> Int toCode = - Elm.Kernel.Char.toCode + Elm.Kernel.Char.toCode {-| Convert a Unicode [code point][cp] to a character. - fromCode 65 == 'A' - fromCode 66 == 'B' - fromCode 0x6728 == '木' - fromCode 0x1D306 == '𝌆' - fromCode 0x1F603 == '😃' - fromCode -1 == '�' + fromCode 65 == 'A' + + fromCode 66 == 'B' + + fromCode 0x6728 == '木' + + fromCode 0x0001D306 == '𝌆' + + fromCode 0x0001F603 == '😃' + + fromCode -1 == '�' The full range of unicode is from `0` to `0x10FFFF`. With numbers outside that range, you get [the replacement character][fffd]. [cp]: https://en.wikipedia.org/wiki/Code_point [fffd]: https://en.wikipedia.org/wiki/Specials_(Unicode_block)#Replacement_character + -} fromCode : Int -> Char fromCode = - Elm.Kernel.Char.fromCode + Elm.Kernel.Char.fromCode diff --git a/src/Debug.elm b/src/Debug.elm index cb8e32f3..fdaae093 100644 --- a/src/Debug.elm +++ b/src/Debug.elm @@ -1,16 +1,14 @@ -module Debug exposing - ( toString - , log - , todo - ) +module Debug exposing (toString, log, todo) {-| This module can be useful while _developing_ an application. It is not available for use in packages or production. + # Debugging + @docs toString, log, todo --} +-} import Elm.Kernel.Debug import String exposing (String) @@ -18,9 +16,12 @@ import String exposing (String) {-| Turn any kind of value into a string. - toString 42 == "42" - toString [1,2] == "[1,2]" - toString ('a', "cat", 13) == "('a', \"cat\", 13)" + toString 42 == "42" + + toString [ 1, 2 ] == "[1,2]" + + toString ( 'a', "cat", 13 ) == "('a', \"cat\", 13)" + toString "he said, \"hi\"" == "\"he said, \\\"hi\\\"\"" Notice that with strings, this is not the `identity` function. It escapes @@ -32,16 +33,18 @@ for viewing Elm data structures. a bunch of runtime metadata. For example, it shortens record field names, and we need that info to `toString` the value! As a consequence, packages cannot use `toString` because they may be used in `--optimize` mode. + -} toString : a -> String toString = - Elm.Kernel.Debug.toString + Elm.Kernel.Debug.toString {-| Log a tagged value on the developer console, and then return the value. - 1 + log "number" 1 -- equals 2, logs "number: 1" - length (log "start" []) -- equals 0, logs "start: []" + 1 + log "number" 1 -- equals 2, logs "number: 1" + + length (log "start" []) -- equals 0, logs "start: []" It is often possible to sprinkle this around to see if values are what you expect. It is kind of old-school to do it this way, but it works! @@ -55,10 +58,11 @@ compiler optimizations that move code around. use ports for now. That will give you full access to reading and writing in the terminal. We may have a package in Elm for this someday, but browser applications are the primary focus of platform development for now. + -} log : String -> a -> a log = - Elm.Kernel.Debug.log + Elm.Kernel.Debug.log {-| This is a placeholder for code that you will write later. @@ -90,8 +94,8 @@ exceptions should not appear in the resulting applications. **Note:** For the equivalent of try/catch error handling in Elm, use modules like [`Maybe`](#Maybe) and [`Result`](#Result) which guarantee that no error goes unhandled! + -} todo : String -> a todo = - Elm.Kernel.Debug.todo - + Elm.Kernel.Debug.todo diff --git a/src/Dict.elm b/src/Dict.elm index 3f80842c..840d1c9c 100644 --- a/src/Dict.elm +++ b/src/Dict.elm @@ -1,49 +1,60 @@ module Dict exposing - ( Dict - , empty, singleton, insert, update, remove - , isEmpty, member, get, size - , keys, values, toList, fromList - , map, foldl, foldr, filter, partition - , union, intersect, diff, merge - ) + ( Dict + , empty, singleton, insert, update, remove + , isEmpty, member, get, size + , keys, values, toList, fromList + , map, foldl, foldr, filter, partition + , union, intersect, diff, merge + ) {-| A dictionary mapping unique keys to values. The keys can be any comparable type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists of comparable types. -Insert, remove, and query operations all take *O(log n)* time. +Insert, remove, and query operations all take _O(log n)_ time. + # Dictionaries + @docs Dict + # Build + @docs empty, singleton, insert, update, remove + # Query + @docs isEmpty, member, get, size + # Lists + @docs keys, values, toList, fromList + # Transform + @docs map, foldl, foldr, filter, partition + # Combine + @docs union, intersect, diff, merge -} - import Basics exposing (..) -import Maybe exposing (..) import List exposing (..) +import Maybe exposing (..) -- DICTIONARIES +-- The color of a node. Leaves are considered Black. --- The color of a node. Leaves are considered Black. type NColor = Red | Black @@ -57,27 +68,29 @@ that lets you look up a `String` (such as user names) and find the associated users : Dict String User users = - Dict.fromList - [ ("Alice", User "Alice" 28 1.65) - , ("Bob" , User "Bob" 19 1.82) - , ("Chuck", User "Chuck" 33 1.75) - ] + Dict.fromList + [ ( "Alice", User "Alice" 28 1.65 ) + , ( "Bob", User "Bob" 19 1.82 ) + , ( "Chuck", User "Chuck" 33 1.75 ) + ] type alias User = - { name : String - , age : Int - , height : Float - } + { name : String + , age : Int + , height : Float + } + -} type Dict k v = RBNode_elm_builtin NColor k v (Dict k v) (Dict k v) | RBEmpty_elm_builtin -{-| Create an empty dictionary. -} +{-| Create an empty dictionary. +-} empty : Dict k v empty = - RBEmpty_elm_builtin + RBEmpty_elm_builtin {-| Get the value associated with a key. If the key is not found, return @@ -93,137 +106,142 @@ dictionary. -} get : comparable -> Dict comparable v -> Maybe v get targetKey dict = - case dict of - RBEmpty_elm_builtin -> - Nothing + case dict of + RBEmpty_elm_builtin -> + Nothing - RBNode_elm_builtin _ key value left right -> - case compare targetKey key of - LT -> - get targetKey left + RBNode_elm_builtin _ key value left right -> + case compare targetKey key of + LT -> + get targetKey left - EQ -> - Just value + EQ -> + Just value - GT -> - get targetKey right + GT -> + get targetKey right -{-| Determine if a key is in a dictionary. -} +{-| Determine if a key is in a dictionary. +-} member : comparable -> Dict comparable v -> Bool member key dict = - case get key dict of - Just _ -> - True + case get key dict of + Just _ -> + True - Nothing -> - False + Nothing -> + False -{-| Determine the number of key-value pairs in the dictionary. -} +{-| Determine the number of key-value pairs in the dictionary. +-} size : Dict k v -> Int size dict = - sizeHelp 0 dict + sizeHelp 0 dict sizeHelp : Int -> Dict k v -> Int sizeHelp n dict = - case dict of - RBEmpty_elm_builtin -> - n + case dict of + RBEmpty_elm_builtin -> + n - RBNode_elm_builtin _ _ _ left right -> - sizeHelp (sizeHelp (n+1) right) left + RBNode_elm_builtin _ _ _ left right -> + sizeHelp (sizeHelp (n + 1) right) left {-| Determine if a dictionary is empty. isEmpty empty == True + -} isEmpty : Dict k v -> Bool isEmpty dict = - case dict of - RBEmpty_elm_builtin -> - True + case dict of + RBEmpty_elm_builtin -> + True - RBNode_elm_builtin _ _ _ _ _ -> - False + RBNode_elm_builtin _ _ _ _ _ -> + False {-| Insert a key-value pair into a dictionary. Replaces value when there is -a collision. -} +a collision. +-} insert : comparable -> v -> Dict comparable v -> Dict comparable v insert key value dict = - -- Root node is always Black - case insertHelp key value dict of - RBNode_elm_builtin Red k v l r -> - RBNode_elm_builtin Black k v l r + -- Root node is always Black + case insertHelp key value dict of + RBNode_elm_builtin Red k v l r -> + RBNode_elm_builtin Black k v l r - x -> - x + x -> + x insertHelp : comparable -> v -> Dict comparable v -> Dict comparable v insertHelp key value dict = - case dict of - RBEmpty_elm_builtin -> - -- New nodes are always red. If it violates the rules, it will be fixed - -- when balancing. - RBNode_elm_builtin Red key value RBEmpty_elm_builtin RBEmpty_elm_builtin + case dict of + RBEmpty_elm_builtin -> + -- New nodes are always red. If it violates the rules, it will be fixed + -- when balancing. + RBNode_elm_builtin Red key value RBEmpty_elm_builtin RBEmpty_elm_builtin - RBNode_elm_builtin nColor nKey nValue nLeft nRight -> - case compare key nKey of - LT -> - balance nColor nKey nValue (insertHelp key value nLeft) nRight + RBNode_elm_builtin nColor nKey nValue nLeft nRight -> + case compare key nKey of + LT -> + balance nColor nKey nValue (insertHelp key value nLeft) nRight - EQ -> - RBNode_elm_builtin nColor nKey value nLeft nRight + EQ -> + RBNode_elm_builtin nColor nKey value nLeft nRight - GT -> - balance nColor nKey nValue nLeft (insertHelp key value nRight) + GT -> + balance nColor nKey nValue nLeft (insertHelp key value nRight) balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v balance color key value left right = - case right of - RBNode_elm_builtin Red rK rV rLeft rRight -> - case left of - RBNode_elm_builtin Red lK lV lLeft lRight -> - RBNode_elm_builtin - Red - key - value - (RBNode_elm_builtin Black lK lV lLeft lRight) - (RBNode_elm_builtin Black rK rV rLeft rRight) + case right of + RBNode_elm_builtin Red rK rV rLeft rRight -> + case left of + RBNode_elm_builtin Red lK lV lLeft lRight -> + RBNode_elm_builtin + Red + key + value + (RBNode_elm_builtin Black lK lV lLeft lRight) + (RBNode_elm_builtin Black rK rV rLeft rRight) + + _ -> + RBNode_elm_builtin color rK rV (RBNode_elm_builtin Red key value left rLeft) rRight _ -> - RBNode_elm_builtin color rK rV (RBNode_elm_builtin Red key value left rLeft) rRight - - _ -> - case left of - RBNode_elm_builtin Red lK lV (RBNode_elm_builtin Red llK llV llLeft llRight) lRight -> - RBNode_elm_builtin - Red - lK - lV - (RBNode_elm_builtin Black llK llV llLeft llRight) - (RBNode_elm_builtin Black key value lRight right) + case left of + RBNode_elm_builtin Red lK lV (RBNode_elm_builtin Red llK llV llLeft llRight) lRight -> + RBNode_elm_builtin + Red + lK + lV + (RBNode_elm_builtin Black llK llV llLeft llRight) + (RBNode_elm_builtin Black key value lRight right) - _ -> - RBNode_elm_builtin color key value left right + _ -> + RBNode_elm_builtin color key value left right {-| Remove a key-value pair from a dictionary. If the key is not found, -no changes are made. -} +no changes are made. +-} remove : comparable -> Dict comparable v -> Dict comparable v remove key dict = - -- Root node is always Black - case removeHelp key dict of - RBNode_elm_builtin Red k v l r -> - RBNode_elm_builtin Black k v l r + -- Root node is always Black + case removeHelp key dict of + RBNode_elm_builtin Red k v l r -> + RBNode_elm_builtin Black k v l r - x -> - x + x -> + x {-| The easiest thing to remove from the tree, is a red node. However, when searching for the @@ -234,53 +252,54 @@ up again. -} removeHelp : comparable -> Dict comparable v -> Dict comparable v removeHelp targetKey dict = - case dict of - RBEmpty_elm_builtin -> - RBEmpty_elm_builtin + case dict of + RBEmpty_elm_builtin -> + RBEmpty_elm_builtin + + RBNode_elm_builtin color key value left right -> + if targetKey < key then + case left of + RBNode_elm_builtin Black _ _ lLeft _ -> + case lLeft of + RBNode_elm_builtin Red _ _ _ _ -> + RBNode_elm_builtin color key value (removeHelp targetKey left) right - RBNode_elm_builtin color key value left right -> - if targetKey < key then - case left of - RBNode_elm_builtin Black _ _ lLeft _ -> - case lLeft of - RBNode_elm_builtin Red _ _ _ _ -> - RBNode_elm_builtin color key value (removeHelp targetKey left) right + _ -> + case moveRedLeft dict of + RBNode_elm_builtin nColor nKey nValue nLeft nRight -> + balance nColor nKey nValue (removeHelp targetKey nLeft) nRight - _ -> - case moveRedLeft dict of - RBNode_elm_builtin nColor nKey nValue nLeft nRight -> - balance nColor nKey nValue (removeHelp targetKey nLeft) nRight + RBEmpty_elm_builtin -> + RBEmpty_elm_builtin - RBEmpty_elm_builtin -> - RBEmpty_elm_builtin + _ -> + RBNode_elm_builtin color key value (removeHelp targetKey left) right - _ -> - RBNode_elm_builtin color key value (removeHelp targetKey left) right - else - removeHelpEQGT targetKey (removeHelpPrepEQGT targetKey dict color key value left right) + else + removeHelpEQGT targetKey (removeHelpPrepEQGT targetKey dict color key value left right) removeHelpPrepEQGT : comparable -> Dict comparable v -> NColor -> comparable -> v -> Dict comparable v -> Dict comparable v -> Dict comparable v removeHelpPrepEQGT targetKey dict color key value left right = - case left of - RBNode_elm_builtin Red lK lV lLeft lRight -> - RBNode_elm_builtin - color - lK - lV - lLeft - (RBNode_elm_builtin Red key value lRight right) - - _ -> - case right of - RBNode_elm_builtin Black _ _ (RBNode_elm_builtin Black _ _ _ _) _ -> - moveRedRight dict - - RBNode_elm_builtin Black _ _ RBEmpty_elm_builtin _ -> - moveRedRight dict + case left of + RBNode_elm_builtin Red lK lV lLeft lRight -> + RBNode_elm_builtin + color + lK + lV + lLeft + (RBNode_elm_builtin Red key value lRight right) _ -> - dict + case right of + RBNode_elm_builtin Black _ _ (RBNode_elm_builtin Black _ _ _ _) _ -> + moveRedRight dict + + RBNode_elm_builtin Black _ _ RBEmpty_elm_builtin _ -> + moveRedRight dict + + _ -> + dict {-| When we find the node we are looking for, we can remove by replacing the key-value @@ -288,139 +307,143 @@ pair with the key-value pair of the left-most node on the right side (the closes -} removeHelpEQGT : comparable -> Dict comparable v -> Dict comparable v removeHelpEQGT targetKey dict = - case dict of - RBNode_elm_builtin color key value left right -> - if targetKey == key then - case getMin right of - RBNode_elm_builtin _ minKey minValue _ _ -> - balance color minKey minValue left (removeMin right) - - RBEmpty_elm_builtin -> - RBEmpty_elm_builtin - else - balance color key value left (removeHelp targetKey right) + case dict of + RBNode_elm_builtin color key value left right -> + if targetKey == key then + case getMin right of + RBNode_elm_builtin _ minKey minValue _ _ -> + balance color minKey minValue left (removeMin right) + + RBEmpty_elm_builtin -> + RBEmpty_elm_builtin - RBEmpty_elm_builtin -> - RBEmpty_elm_builtin + else + balance color key value left (removeHelp targetKey right) + + RBEmpty_elm_builtin -> + RBEmpty_elm_builtin getMin : Dict k v -> Dict k v getMin dict = - case dict of - RBNode_elm_builtin _ _ _ ((RBNode_elm_builtin _ _ _ _ _) as left) _ -> - getMin left + case dict of + RBNode_elm_builtin _ _ _ ((RBNode_elm_builtin _ _ _ _ _) as left) _ -> + getMin left - _ -> - dict + _ -> + dict removeMin : Dict k v -> Dict k v removeMin dict = - case dict of - RBNode_elm_builtin color key value ((RBNode_elm_builtin lColor _ _ lLeft _) as left) right -> - case lColor of - Black -> - case lLeft of - RBNode_elm_builtin Red _ _ _ _ -> - RBNode_elm_builtin color key value (removeMin left) right - - _ -> - case moveRedLeft dict of - RBNode_elm_builtin nColor nKey nValue nLeft nRight -> - balance nColor nKey nValue (removeMin nLeft) nRight - - RBEmpty_elm_builtin -> - RBEmpty_elm_builtin + case dict of + RBNode_elm_builtin color key value ((RBNode_elm_builtin lColor _ _ lLeft _) as left) right -> + case lColor of + Black -> + case lLeft of + RBNode_elm_builtin Red _ _ _ _ -> + RBNode_elm_builtin color key value (removeMin left) right - _ -> - RBNode_elm_builtin color key value (removeMin left) right + _ -> + case moveRedLeft dict of + RBNode_elm_builtin nColor nKey nValue nLeft nRight -> + balance nColor nKey nValue (removeMin nLeft) nRight - _ -> - RBEmpty_elm_builtin + RBEmpty_elm_builtin -> + RBEmpty_elm_builtin + + _ -> + RBNode_elm_builtin color key value (removeMin left) right + + _ -> + RBEmpty_elm_builtin moveRedLeft : Dict k v -> Dict k v moveRedLeft dict = - case dict of - RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV lLeft lRight) (RBNode_elm_builtin rClr rK rV ((RBNode_elm_builtin Red rlK rlV rlL rlR) as rLeft) rRight) -> - RBNode_elm_builtin - Red - rlK - rlV - (RBNode_elm_builtin Black k v (RBNode_elm_builtin Red lK lV lLeft lRight) rlL) - (RBNode_elm_builtin Black rK rV rlR rRight) - - RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV lLeft lRight) (RBNode_elm_builtin rClr rK rV rLeft rRight) -> - case clr of - Black -> - RBNode_elm_builtin - Black - k - v - (RBNode_elm_builtin Red lK lV lLeft lRight) - (RBNode_elm_builtin Red rK rV rLeft rRight) - - Red -> - RBNode_elm_builtin - Black - k - v - (RBNode_elm_builtin Red lK lV lLeft lRight) - (RBNode_elm_builtin Red rK rV rLeft rRight) - - _ -> - dict + case dict of + RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV lLeft lRight) (RBNode_elm_builtin rClr rK rV ((RBNode_elm_builtin Red rlK rlV rlL rlR) as rLeft) rRight) -> + RBNode_elm_builtin + Red + rlK + rlV + (RBNode_elm_builtin Black k v (RBNode_elm_builtin Red lK lV lLeft lRight) rlL) + (RBNode_elm_builtin Black rK rV rlR rRight) + + RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV lLeft lRight) (RBNode_elm_builtin rClr rK rV rLeft rRight) -> + case clr of + Black -> + RBNode_elm_builtin + Black + k + v + (RBNode_elm_builtin Red lK lV lLeft lRight) + (RBNode_elm_builtin Red rK rV rLeft rRight) + + Red -> + RBNode_elm_builtin + Black + k + v + (RBNode_elm_builtin Red lK lV lLeft lRight) + (RBNode_elm_builtin Red rK rV rLeft rRight) + + _ -> + dict moveRedRight : Dict k v -> Dict k v moveRedRight dict = - case dict of - RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV (RBNode_elm_builtin Red llK llV llLeft llRight) lRight) (RBNode_elm_builtin rClr rK rV rLeft rRight) -> - RBNode_elm_builtin - Red - lK - lV - (RBNode_elm_builtin Black llK llV llLeft llRight) - (RBNode_elm_builtin Black k v lRight (RBNode_elm_builtin Red rK rV rLeft rRight)) - - RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV lLeft lRight) (RBNode_elm_builtin rClr rK rV rLeft rRight) -> - case clr of - Black -> - RBNode_elm_builtin - Black - k - v - (RBNode_elm_builtin Red lK lV lLeft lRight) - (RBNode_elm_builtin Red rK rV rLeft rRight) - - Red -> - RBNode_elm_builtin - Black - k - v - (RBNode_elm_builtin Red lK lV lLeft lRight) - (RBNode_elm_builtin Red rK rV rLeft rRight) - - _ -> - dict - - -{-| Update the value of a dictionary for a specific key with a given function. -} + case dict of + RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV (RBNode_elm_builtin Red llK llV llLeft llRight) lRight) (RBNode_elm_builtin rClr rK rV rLeft rRight) -> + RBNode_elm_builtin + Red + lK + lV + (RBNode_elm_builtin Black llK llV llLeft llRight) + (RBNode_elm_builtin Black k v lRight (RBNode_elm_builtin Red rK rV rLeft rRight)) + + RBNode_elm_builtin clr k v (RBNode_elm_builtin lClr lK lV lLeft lRight) (RBNode_elm_builtin rClr rK rV rLeft rRight) -> + case clr of + Black -> + RBNode_elm_builtin + Black + k + v + (RBNode_elm_builtin Red lK lV lLeft lRight) + (RBNode_elm_builtin Red rK rV rLeft rRight) + + Red -> + RBNode_elm_builtin + Black + k + v + (RBNode_elm_builtin Red lK lV lLeft lRight) + (RBNode_elm_builtin Red rK rV rLeft rRight) + + _ -> + dict + + +{-| Update the value of a dictionary for a specific key with a given function. +-} update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v update targetKey alter dictionary = - case alter (get targetKey dictionary) of - Just value -> - insert targetKey value dictionary + case alter (get targetKey dictionary) of + Just value -> + insert targetKey value dictionary - Nothing -> - remove targetKey dictionary + Nothing -> + remove targetKey dictionary -{-| Create a dictionary with one key-value pair. -} +{-| Create a dictionary with one key-value pair. +-} singleton : comparable -> v -> Dict comparable v singleton key value = - -- Root node is always Black - RBNode_elm_builtin Black key value RBEmpty_elm_builtin RBEmpty_elm_builtin + -- Root node is always Black + RBNode_elm_builtin Black key value RBEmpty_elm_builtin RBEmpty_elm_builtin + -- COMBINE @@ -431,7 +454,7 @@ to the first dictionary. -} union : Dict comparable v -> Dict comparable v -> Dict comparable v union t1 t2 = - foldl insert t2 t1 + foldl insert t2 t1 {-| Keep a key-value pair when its key appears in the second dictionary. @@ -439,55 +462,56 @@ Preference is given to values in the first dictionary. -} intersect : Dict comparable v -> Dict comparable v -> Dict comparable v intersect t1 t2 = - filter (\k _ -> member k t2) t1 + filter (\k _ -> member k t2) t1 {-| Keep a key-value pair when its key does not appear in the second dictionary. -} diff : Dict comparable a -> Dict comparable b -> Dict comparable a diff t1 t2 = - foldl (\k v t -> remove k t) t1 t2 + foldl (\k v t -> remove k t) t1 t2 {-| The most general way of combining two dictionaries. You provide three accumulators for when a given key appears: - 1. Only in the left dictionary. - 2. In both dictionaries. - 3. Only in the right dictionary. +1. Only in the left dictionary. +2. In both dictionaries. +3. Only in the right dictionary. You then traverse all the keys from lowest to highest, building up whatever you want. + -} -merge - : (comparable -> a -> result -> result) - -> (comparable -> a -> b -> result -> result) - -> (comparable -> b -> result -> result) - -> Dict comparable a - -> Dict comparable b - -> result - -> result +merge : + (comparable -> a -> result -> result) + -> (comparable -> a -> b -> result -> result) + -> (comparable -> b -> result -> result) + -> Dict comparable a + -> Dict comparable b + -> result + -> result merge leftStep bothStep rightStep leftDict rightDict initialResult = - let - stepState rKey rValue (list, result) = - case list of - [] -> - (list, rightStep rKey rValue result) + let + stepState rKey rValue ( list, result ) = + case list of + [] -> + ( list, rightStep rKey rValue result ) - (lKey, lValue) :: rest -> - if lKey < rKey then - stepState rKey rValue (rest, leftStep lKey lValue result) + ( lKey, lValue ) :: rest -> + if lKey < rKey then + stepState rKey rValue ( rest, leftStep lKey lValue result ) - else if lKey > rKey then - (list, rightStep rKey rValue result) + else if lKey > rKey then + ( list, rightStep rKey rValue result ) - else - (rest, bothStep lKey lValue rValue result) + else + ( rest, bothStep lKey lValue rValue result ) - (leftovers, intermediateResult) = - foldl stepState (toList leftDict, initialResult) rightDict - in - List.foldl (\(k,v) result -> leftStep k v result) intermediateResult leftovers + ( leftovers, intermediateResult ) = + foldl stepState ( toList leftDict, initialResult ) rightDict + in + List.foldl (\( k, v ) result -> leftStep k v result) intermediateResult leftovers @@ -498,12 +522,12 @@ merge leftStep bothStep rightStep leftDict rightDict initialResult = -} map : (k -> a -> b) -> Dict k a -> Dict k b map func dict = - case dict of - RBEmpty_elm_builtin -> - RBEmpty_elm_builtin + case dict of + RBEmpty_elm_builtin -> + RBEmpty_elm_builtin - RBNode_elm_builtin color key value left right -> - RBNode_elm_builtin color key (func key value) (map func left) (map func right) + RBNode_elm_builtin color key value left right -> + RBNode_elm_builtin color key (func key value) (map func left) (map func right) {-| Fold over the key-value pairs in a dictionary from lowest key to highest key. @@ -512,22 +536,23 @@ map func dict = getAges : Dict String User -> List String getAges users = - Dict.foldl addAge [] users + Dict.foldl addAge [] users addAge : String -> User -> List String -> List String addAge _ user ages = - user.age :: ages + user.age :: ages -- getAges users == [33,19,28] + -} foldl : (k -> v -> b -> b) -> b -> Dict k v -> b foldl func acc dict = - case dict of - RBEmpty_elm_builtin -> - acc + case dict of + RBEmpty_elm_builtin -> + acc - RBNode_elm_builtin _ key value left right -> - foldl func (func key value (foldl func acc left)) right + RBNode_elm_builtin _ key value left right -> + foldl func (func key value (foldl func acc left)) right {-| Fold over the key-value pairs in a dictionary from highest key to lowest key. @@ -536,45 +561,57 @@ foldl func acc dict = getAges : Dict String User -> List String getAges users = - Dict.foldr addAge [] users + Dict.foldr addAge [] users addAge : String -> User -> List String -> List String addAge _ user ages = - user.age :: ages + user.age :: ages -- getAges users == [28,19,33] + -} foldr : (k -> v -> b -> b) -> b -> Dict k v -> b foldr func acc t = - case t of - RBEmpty_elm_builtin -> - acc + case t of + RBEmpty_elm_builtin -> + acc - RBNode_elm_builtin _ key value left right -> - foldr func (func key value (foldr func acc right)) left + RBNode_elm_builtin _ key value left right -> + foldr func (func key value (foldr func acc right)) left -{-| Keep only the key-value pairs that pass the given test. -} +{-| Keep only the key-value pairs that pass the given test. +-} filter : (comparable -> v -> Bool) -> Dict comparable v -> Dict comparable v filter isGood dict = - foldl (\k v d -> if isGood k v then insert k v d else d) empty dict + foldl + (\k v d -> + if isGood k v then + insert k v d + + else + d + ) + empty + dict {-| Partition a dictionary according to some test. The first dictionary contains all key-value pairs which passed the test, and the second contains the pairs that did not. -} -partition : (comparable -> v -> Bool) -> Dict comparable v -> (Dict comparable v, Dict comparable v) +partition : (comparable -> v -> Bool) -> Dict comparable v -> ( Dict comparable v, Dict comparable v ) partition isGood dict = - let - add key value (t1, t2) = - if isGood key value then - (insert key value t1, t2) + let + add key value ( t1, t2 ) = + if isGood key value then + ( insert key value t1, t2 ) + + else + ( t1, insert key value t2 ) + in + foldl add ( empty, empty ) dict - else - (t1, insert key value t2) - in - foldl add (empty, empty) dict -- LISTS @@ -582,29 +619,33 @@ partition isGood dict = {-| Get all of the keys in a dictionary, sorted from lowest to highest. - keys (fromList [(0,"Alice"),(1,"Bob")]) == [0,1] + keys (fromList [ ( 0, "Alice" ), ( 1, "Bob" ) ]) == [ 0, 1 ] + -} keys : Dict k v -> List k keys dict = - foldr (\key value keyList -> key :: keyList) [] dict + foldr (\key value keyList -> key :: keyList) [] dict {-| Get all of the values in a dictionary, in the order of their keys. - values (fromList [(0,"Alice"),(1,"Bob")]) == ["Alice", "Bob"] + values (fromList [ ( 0, "Alice" ), ( 1, "Bob" ) ]) == [ "Alice", "Bob" ] + -} values : Dict k v -> List v values dict = - foldr (\key value valueList -> value :: valueList) [] dict + foldr (\key value valueList -> value :: valueList) [] dict -{-| Convert a dictionary into an association list of key-value pairs, sorted by keys. -} -toList : Dict k v -> List (k,v) +{-| Convert a dictionary into an association list of key-value pairs, sorted by keys. +-} +toList : Dict k v -> List ( k, v ) toList dict = - foldr (\key value list -> (key,value) :: list) [] dict + foldr (\key value list -> ( key, value ) :: list) [] dict -{-| Convert an association list into a dictionary. -} -fromList : List (comparable,v) -> Dict comparable v +{-| Convert an association list into a dictionary. +-} +fromList : List ( comparable, v ) -> Dict comparable v fromList assocs = - List.foldl (\(key,value) dict -> insert key value dict) empty assocs + List.foldl (\( key, value ) dict -> insert key value dict) empty assocs diff --git a/src/Elm/JsArray.elm b/src/Elm/JsArray.elm index 40076231..a29d4c79 100644 --- a/src/Elm/JsArray.elm +++ b/src/Elm/JsArray.elm @@ -1,47 +1,42 @@ -module Elm.JsArray - exposing - ( JsArray - , empty - , singleton - , length - , initialize - , initializeFromList - , unsafeGet - , unsafeSet - , push - , foldl - , foldr - , map - , indexedMap - , slice - , appendN - ) +module Elm.JsArray exposing + ( JsArray + , empty, singleton, initialize + , length, unsafeGet, unsafeSet, push + , foldl, foldr, map, slice + , appendN, indexedMap, initializeFromList + ) {-| This library provides an immutable version of native javascript arrays. NOTE: All manipulations causes a copy of the entire array, this can be slow. For general purpose use, try the `Array` module instead. + # Arrays + @docs JsArray + # Creation + @docs empty, singleton, initialize, listInitialize + # Basics + @docs length, unsafeGet, unsafeSet, push + # Transformation + @docs foldl, foldr, map, slice, merge -} - import Basics exposing (Int) import Elm.Kernel.JsArray - {-| Representation of a javascript array. -} type JsArray a @@ -75,7 +70,8 @@ with the element at index `i` initialized to the result of `(f (i + offset))`. The offset parameter is there so one can avoid creating a closure for this use case. This is an optimization that has proved useful in the `Array` module. - initialize 3 5 identity == [5,6,7] + initialize 3 5 identity == [ 5, 6, 7 ] + -} initialize : Int -> Int -> (Int -> a) -> JsArray a initialize = @@ -91,6 +87,7 @@ to create `JsArray`s above a certain size. That being said, because every manipulation of `JsArray` results in a copy, users should always try to keep these as small as possible. The `n` parameter should always be set to a reasonably small value. + -} initializeFromList : Int -> List a -> ( JsArray a, List a ) initializeFromList = @@ -101,6 +98,7 @@ initializeFromList = WARNING: This function does not perform bounds checking. Make sure you know the index is within bounds when using this function. + -} unsafeGet : Int -> JsArray a -> a unsafeGet = @@ -111,6 +109,7 @@ unsafeGet = WARNING: This function does not perform bounds checking. Make sure you know the index is within bounds when using this function. + -} unsafeSet : Int -> a -> JsArray a -> JsArray a unsafeSet = @@ -148,7 +147,8 @@ map = {-| Apply a function on every element and its index in an array. An offset allows to modify the index passed to the function. - indexedMap (,) 5 (repeat 3 3) == Array [(5,3), (6,3), (7,3)] + indexedMap (,) 5 (repeat 3 3) == Array [ ( 5, 3 ), ( 6, 3 ), ( 7, 3 ) ] + -} indexedMap : (Int -> a -> b) -> Int -> JsArray a -> JsArray b indexedMap = @@ -165,6 +165,7 @@ of the array. Popping the last element of the array is therefore: `slice 0 -1 arr`. In the case of an impossible slice, the empty array is returned. + -} slice : Int -> Int -> JsArray a -> JsArray a slice = @@ -175,6 +176,7 @@ slice = The `n` parameter is required by the `Array` module, which never wants to create `JsArray`s above a certain size, even when appending. + -} appendN : Int -> JsArray a -> JsArray a -> JsArray a appendN = diff --git a/src/List.elm b/src/List.elm index 85119142..f6502c7d 100644 --- a/src/List.elm +++ b/src/List.elm @@ -1,41 +1,51 @@ module List exposing - ( singleton, repeat, range, (::) - , map, indexedMap, foldl, foldr, filter, filterMap - , length, reverse, member, all, any, maximum, minimum, sum, product - , append, concat, concatMap, intersperse, map2, map3, map4, map5 - , sort, sortBy, sortWith - , isEmpty, head, tail, take, drop, partition, unzip - ) + ( singleton, repeat, range, (::) + , map, indexedMap, foldl, foldr, filter, filterMap + , length, reverse, member, all, any, maximum, minimum, sum, product + , append, concat, concatMap, intersperse, map2, map3, map4, map5 + , sort, sortBy, sortWith + , isEmpty, head, tail, take, drop, partition, unzip + ) {-| You can create a `List` in Elm with the `[1,2,3]` syntax, so lists are used all over the place. This module has a bunch of functions to help you work with them! + # Create + @docs singleton, repeat, range, (::) + # Transform + @docs map, indexedMap, foldl, foldr, filter, filterMap + # Utilities + @docs length, reverse, member, all, any, maximum, minimum, sum, product + # Combine + @docs append, concat, concatMap, intersperse, map2, map3, map4, map5 + # Sort + @docs sort, sortBy, sortWith + # Deconstruct + @docs isEmpty, head, tail, take, drop, partition, unzip -} import Basics exposing (..) import Elm.Kernel.List -import Maybe exposing ( Maybe(..) ) - - +import Maybe exposing (Maybe(..)) infix right 5 (::) = cons @@ -45,67 +55,74 @@ infix right 5 (::) = cons -- CREATE - {-| Create a list with only one element: - singleton 1234 == [1234] - singleton "hi" == ["hi"] + singleton 1234 == [ 1234 ] + + singleton "hi" == [ "hi" ] + -} singleton : a -> List a singleton value = - [value] + [ value ] -{-| Create a list with *n* copies of a value: +{-| Create a list with _n_ copies of a value: + + repeat 3 ( 0, 0 ) == [ ( 0, 0 ), ( 0, 0 ), ( 0, 0 ) ] - repeat 3 (0,0) == [(0,0),(0,0),(0,0)] -} repeat : Int -> a -> List a repeat n value = - repeatHelp [] n value + repeatHelp [] n value repeatHelp : List a -> Int -> a -> List a repeatHelp result n value = - if n <= 0 then - result + if n <= 0 then + result - else - repeatHelp (cons value result) (n-1) value + else + repeatHelp (cons value result) (n - 1) value {-| Create a list of numbers, every element increasing by one. You give the lowest and highest number that should be in the list. - range 3 6 == [3, 4, 5, 6] - range 3 3 == [3] + range 3 6 == [ 3, 4, 5, 6 ] + + range 3 3 == [ 3 ] + range 6 3 == [] + -} range : Int -> Int -> List Int range lo hi = - rangeHelp lo hi [] + rangeHelp lo hi [] rangeHelp : Int -> Int -> List Int -> List Int rangeHelp lo hi list = - if lo <= hi then - rangeHelp lo (hi - 1) (cons hi list) + if lo <= hi then + rangeHelp lo (hi - 1) (cons hi list) - else - list + else + list {-| Add an element to the front of a list. - 1 :: [2,3] == [1,2,3] - 1 :: [] == [1] + 1 :: [ 2, 3 ] == [ 1, 2, 3 ] + + 1 :: [] == [ 1 ] -This operator is pronounced *cons* for historical reasons, but you can think +This operator is pronounced _cons_ for historical reasons, but you can think of it like pushing an entry onto a stack. + -} cons : a -> List a -> List a cons = - Elm.Kernel.List.cons + Elm.Kernel.List.cons @@ -114,60 +131,66 @@ cons = {-| Apply a function to every element of a list. - map sqrt [1,4,9] == [1,2,3] + map sqrt [ 1, 4, 9 ] == [ 1, 2, 3 ] - map not [True,False,True] == [False,True,False] + map not [ True, False, True ] == [ False, True, False ] So `map func [ a, b, c ]` is the same as `[ func a, func b, func c ]` + -} map : (a -> b) -> List a -> List b map f xs = - foldr (\x acc -> cons (f x) acc) [] xs + foldr (\x acc -> cons (f x) acc) [] xs {-| Same as `map` but the function is also applied to the index of each element (starting at zero). - indexedMap Tuple.pair ["Tom","Sue","Bob"] == [ (0,"Tom"), (1,"Sue"), (2,"Bob") ] + indexedMap Tuple.pair [ "Tom", "Sue", "Bob" ] == [ ( 0, "Tom" ), ( 1, "Sue" ), ( 2, "Bob" ) ] + -} indexedMap : (Int -> a -> b) -> List a -> List b indexedMap f xs = - map2 f (range 0 (length xs - 1)) xs + map2 f (range 0 (length xs - 1)) xs {-| Reduce a list from the left. - foldl (+) 0 [1,2,3] == 6 - foldl (::) [] [1,2,3] == [3,2,1] + foldl (+) 0 [ 1, 2, 3 ] == 6 + + foldl (::) [] [ 1, 2, 3 ] == [ 3, 2, 1 ] So `foldl step state [1,2,3]` is like saying: state - |> step 1 - |> step 2 - |> step 3 + |> step 1 + |> step 2 + |> step 3 + -} foldl : (a -> b -> b) -> b -> List a -> b foldl func acc list = - case list of - [] -> - acc + case list of + [] -> + acc - x :: xs -> - foldl func (func x acc) xs + x :: xs -> + foldl func (func x acc) xs {-| Reduce a list from the right. - foldr (+) 0 [1,2,3] == 6 - foldr (::) [] [1,2,3] == [1,2,3] + foldr (+) 0 [ 1, 2, 3 ] == 6 + + foldr (::) [] [ 1, 2, 3 ] == [ 1, 2, 3 ] So `foldr step state [1,2,3]` is like saying: state - |> step 3 - |> step 2 - |> step 1 + |> step 3 + |> step 2 + |> step 1 + -} foldr : (a -> b -> b) -> b -> List a -> b foldr fn acc ls = @@ -200,44 +223,57 @@ foldrHelper fn acc ctr ls = res = if ctr > 500 then foldl fn acc (reverse r4) + else foldrHelper fn acc (ctr + 1) r4 in - fn a (fn b (fn c (fn d res))) + fn a (fn b (fn c (fn d res))) {-| Keep elements that satisfy the test. - filter isEven [1,2,3,4,5,6] == [2,4,6] + filter isEven [ 1, 2, 3, 4, 5, 6 ] == [ 2, 4, 6 ] + -} filter : (a -> Bool) -> List a -> List a filter isGood list = - foldr (\x xs -> if isGood x then cons x xs else xs) [] list + foldr + (\x xs -> + if isGood x then + cons x xs + + else + xs + ) + [] + list {-| Filter out certain values. For example, maybe you have a bunch of strings from an untrusted source and you want to turn them into numbers: + numbers : List Int numbers = - filterMap String.toInt ["3", "hi", "12", "4th", "May"] + filterMap String.toInt [ "3", "hi", "12", "4th", "May" ] -- numbers == [3, 12] -} filterMap : (a -> Maybe b) -> List a -> List b filterMap f xs = - foldr (maybeCons f) [] xs + foldr (maybeCons f) [] xs maybeCons : (a -> Maybe b) -> a -> List b -> List b maybeCons f mx xs = - case f mx of - Just x -> - cons x xs + case f mx of + Just x -> + cons x xs + + Nothing -> + xs - Nothing -> - xs -- UTILITIES @@ -245,116 +281,134 @@ maybeCons f mx xs = {-| Determine the length of a list. - length [1,2,3] == 3 + length [ 1, 2, 3 ] == 3 + -} length : List a -> Int length xs = - foldl (\_ i -> i + 1) 0 xs + foldl (\_ i -> i + 1) 0 xs {-| Reverse a list. - reverse [1,2,3,4] == [4,3,2,1] + reverse [ 1, 2, 3, 4 ] == [ 4, 3, 2, 1 ] + -} reverse : List a -> List a reverse list = - foldl cons [] list + foldl cons [] list {-| Figure out whether a list contains a value. - member 9 [1,2,3,4] == False - member 4 [1,2,3,4] == True + member 9 [ 1, 2, 3, 4 ] == False + + member 4 [ 1, 2, 3, 4 ] == True + -} member : a -> List a -> Bool member x xs = - any (\a -> a == x) xs + any (\a -> a == x) xs {-| Determine if all elements satisfy some test. - all isEven [2,4] == True - all isEven [2,3] == False + all isEven [ 2, 4 ] == True + + all isEven [ 2, 3 ] == False + all isEven [] == True + -} all : (a -> Bool) -> List a -> Bool all isOkay list = - not (any (not << isOkay) list) + not (any (not << isOkay) list) {-| Determine if any elements satisfy some test. - any isEven [2,3] == True - any isEven [1,3] == False + any isEven [ 2, 3 ] == True + + any isEven [ 1, 3 ] == False + any isEven [] == False + -} any : (a -> Bool) -> List a -> Bool any isOkay list = - case list of - [] -> - False + case list of + [] -> + False - x :: xs -> - -- note: (isOkay x || any isOkay xs) would not get TCO - if isOkay x then - True + x :: xs -> + -- note: (isOkay x || any isOkay xs) would not get TCO + if isOkay x then + True - else - any isOkay xs + else + any isOkay xs {-| Find the maximum element in a non-empty list. - maximum [1,4,2] == Just 4 - maximum [] == Nothing + maximum [ 1, 4, 2 ] == Just 4 + + maximum [] == Nothing + -} maximum : List comparable -> Maybe comparable maximum list = - case list of - x :: xs -> - Just (foldl max x xs) + case list of + x :: xs -> + Just (foldl max x xs) - _ -> - Nothing + _ -> + Nothing {-| Find the minimum element in a non-empty list. - minimum [3,2,1] == Just 1 - minimum [] == Nothing + minimum [ 3, 2, 1 ] == Just 1 + + minimum [] == Nothing + -} minimum : List comparable -> Maybe comparable minimum list = - case list of - x :: xs -> - Just (foldl min x xs) + case list of + x :: xs -> + Just (foldl min x xs) - _ -> - Nothing + _ -> + Nothing {-| Get the sum of the list elements. - sum [1,2,3] == 6 - sum [1,1,1] == 3 - sum [] == 0 + sum [ 1, 2, 3 ] == 6 + + sum [ 1, 1, 1 ] == 3 + + sum [] == 0 -} sum : List number -> number sum numbers = - foldl (+) 0 numbers + foldl (+) 0 numbers {-| Get the product of the list elements. - product [2,2,2] == 8 - product [3,3,3] == 27 - product [] == 1 + product [ 2, 2, 2 ] == 8 + + product [ 3, 3, 3 ] == 27 + + product [] == 1 -} product : List number -> number product numbers = - foldl (*) 1 numbers + foldl (*) 1 numbers @@ -363,72 +417,77 @@ product numbers = {-| Put two lists together. - append [1,1,2] [3,5,8] == [1,1,2,3,5,8] - append ['a','b'] ['c'] == ['a','b','c'] + append [ 1, 1, 2 ] [ 3, 5, 8 ] == [ 1, 1, 2, 3, 5, 8 ] + + append [ 'a', 'b' ] [ 'c' ] == [ 'a', 'b', 'c' ] You can also use [the `(++)` operator](Basics#++) to append lists. + -} append : List a -> List a -> List a append xs ys = - case ys of - [] -> - xs + case ys of + [] -> + xs - _ -> - foldr cons ys xs + _ -> + foldr cons ys xs {-| Concatenate a bunch of lists into a single list: - concat [[1,2],[3],[4,5]] == [1,2,3,4,5] + concat [ [ 1, 2 ], [ 3 ], [ 4, 5 ] ] == [ 1, 2, 3, 4, 5 ] + -} concat : List (List a) -> List a concat lists = - foldr append [] lists + foldr append [] lists {-| Map a given function onto a list and flatten the resulting lists. concatMap f xs == concat (map f xs) + -} concatMap : (a -> List b) -> List a -> List b concatMap f list = - concat (map f list) + concat (map f list) {-| Places the given value between all members of the given list. - intersperse "on" ["turtles","turtles","turtles"] == ["turtles","on","turtles","on","turtles"] + intersperse "on" [ "turtles", "turtles", "turtles" ] == [ "turtles", "on", "turtles", "on", "turtles" ] + -} intersperse : a -> List a -> List a intersperse sep xs = - case xs of - [] -> - [] + case xs of + [] -> + [] - hd :: tl -> - let - step x rest = - cons sep (cons x rest) + hd :: tl -> + let + step x rest = + cons sep (cons x rest) - spersed = - foldr step [] tl - in - cons hd spersed + spersed = + foldr step [] tl + in + cons hd spersed {-| Combine two lists, combining them with the given function. If one list is longer, the extra elements are dropped. + totals : List Int -> List Int -> List Int totals xs ys = - List.map2 (+) xs ys + List.map2 (+) xs ys -- totals [1,2,3] [4,5,6] == [5,7,9] - - pairs : List a -> List b -> List (a,b) + pairs : List a -> List b -> List ( a, b ) pairs xs ys = - List.map2 Tuple.pair xs ys + List.map2 Tuple.pair xs ys -- pairs ["alice","bob","chuck"] [2,5,7,8] -- == [("alice",2),("bob",5),("chuck",7)] @@ -436,59 +495,66 @@ If one list is longer, the extra elements are dropped. -} map2 : (a -> b -> result) -> List a -> List b -> List result map2 f xs1 xs2 = - reverse (map2Help f xs1 xs2 []) + reverse (map2Help f xs1 xs2 []) -{-|-} +{-| -} map3 : (a -> b -> c -> result) -> List a -> List b -> List c -> List result map3 f xs1 xs2 xs3 = - reverse (map3Help f xs1 xs2 xs3 []) + reverse (map3Help f xs1 xs2 xs3 []) -{-|-} +{-| -} map4 : (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result map4 f xs1 xs2 xs3 xs4 = - reverse (map4Help f xs1 xs2 xs3 xs4 []) + reverse (map4Help f xs1 xs2 xs3 xs4 []) -{-|-} +{-| -} map5 : (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result map5 f xs1 xs2 xs3 xs4 xs5 = - reverse (map5Help f xs1 xs2 xs3 xs4 xs5 []) + reverse (map5Help f xs1 xs2 xs3 xs4 xs5 []) -map2Help : (a -> b -> result) -> List a -> List b -> List result -> List result +map2Help : (a -> b -> result) -> List a -> List b -> List result -> List result map2Help f xs1 xs2 ys = - case (xs1, xs2) of - (head1 :: rest1, head2 :: rest2) -> - map2Help f rest1 rest2 (cons (f head1 head2) ys) - _ -> - ys + case ( xs1, xs2 ) of + ( head1 :: rest1, head2 :: rest2 ) -> + map2Help f rest1 rest2 (cons (f head1 head2) ys) -map3Help : (a -> b -> c -> result) -> List a -> List b -> List c-> List result -> List result + _ -> + ys + + +map3Help : (a -> b -> c -> result) -> List a -> List b -> List c -> List result -> List result map3Help f xs1 xs2 xs3 ys = - case (xs1, xs2, xs3) of - (head1 :: rest1, head2 :: rest2, head3 :: rest3) -> - map3Help f rest1 rest2 rest3 (cons (f head1 head2 head3) ys) - _ -> - ys + case ( xs1, xs2, xs3 ) of + ( head1 :: rest1, head2 :: rest2, head3 :: rest3 ) -> + map3Help f rest1 rest2 rest3 (cons (f head1 head2 head3) ys) + + _ -> + ys + map4Help : (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result -> List result map4Help f xs1 xs2 xs3 xs4 ys = - case (xs1, xs2, (xs3, xs4)) of - (head1 :: rest1, head2 :: rest2, (head3 :: rest3, head4 :: rest4)) -> - map4Help f rest1 rest2 rest3 rest4 (cons (f head1 head2 head3 head4) ys) - _ -> - ys + case ( xs1, xs2, ( xs3, xs4 ) ) of + ( head1 :: rest1, head2 :: rest2, ( head3 :: rest3, head4 :: rest4 ) ) -> + map4Help f rest1 rest2 rest3 rest4 (cons (f head1 head2 head3 head4) ys) + + _ -> + ys map5Help : (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result -> List result map5Help f xs1 xs2 xs3 xs4 xs5 ys = - case (xs1, xs2, (xs3, xs4, xs5)) of - (head1 :: rest1, head2 :: rest2, (head3 :: rest3, head4 :: rest4, head5 :: rest5)) -> - map5Help f rest1 rest2 rest3 rest4 rest5 (cons (f head1 head2 head3 head4 head5) ys) - _ -> - ys + case ( xs1, xs2, ( xs3, xs4, xs5 ) ) of + ( head1 :: rest1, head2 :: rest2, ( head3 :: rest3, head4 :: rest4, head5 :: rest5 ) ) -> + map5Help f rest1 rest2 rest3 rest4 rest5 (cons (f head1 head2 head3 head4 head5) ys) + + _ -> + ys + -- SORT @@ -496,11 +562,12 @@ map5Help f xs1 xs2 xs3 xs4 xs5 ys = {-| Sort values from lowest to highest - sort [3,1,5] == [1,3,5] + sort [ 3, 1, 5 ] == [ 1, 3, 5 ] + -} sort : List comparable -> List comparable sort xs = - sortBy identity xs + sortBy identity xs {-| Sort values by a derived property. @@ -513,10 +580,11 @@ sort xs = sortBy .height [chuck,alice,bob] == [alice,chuck,bob] sortBy String.length ["mouse","cat"] == ["cat","mouse"] + -} sortBy : (a -> comparable) -> List a -> List a sortBy = - Elm.Kernel.List.sortBy + Elm.Kernel.List.sortBy {-| Sort values with a custom comparison function. @@ -531,10 +599,11 @@ sortBy = This is also the most general sort function, allowing you to define any other: `sort == sortWith compare` + -} sortWith : (a -> a -> Order) -> List a -> List a sortWith = - Elm.Kernel.List.sortWith + Elm.Kernel.List.sortWith @@ -547,152 +616,166 @@ sortWith = **Note:** It is usually preferable to use a `case` to test this so you do not forget to handle the `(x :: xs)` case as well! + -} isEmpty : List a -> Bool isEmpty xs = - case xs of - [] -> - True + case xs of + [] -> + True - _ -> - False + _ -> + False {-| Extract the first element of a list. - head [1,2,3] == Just 1 + head [ 1, 2, 3 ] == Just 1 + head [] == Nothing **Note:** It is usually preferable to use a `case` to deconstruct a `List` because it gives you `(x :: xs)` and you can work with both subparts. + -} head : List a -> Maybe a head list = - case list of - x :: xs -> - Just x + case list of + x :: xs -> + Just x - [] -> - Nothing + [] -> + Nothing {-| Extract the rest of the list. - tail [1,2,3] == Just [2,3] + tail [ 1, 2, 3 ] == Just [ 2, 3 ] + tail [] == Nothing **Note:** It is usually preferable to use a `case` to deconstruct a `List` because it gives you `(x :: xs)` and you can work with both subparts. + -} tail : List a -> Maybe (List a) tail list = - case list of - x :: xs -> - Just xs + case list of + x :: xs -> + Just xs + + [] -> + Nothing - [] -> - Nothing +{-| Take the first _n_ members of a list. -{-| Take the first *n* members of a list. + take 2 [ 1, 2, 3, 4 ] == [ 1, 2 ] - take 2 [1,2,3,4] == [1,2] -} take : Int -> List a -> List a take n list = - takeFast 0 n list + takeFast 0 n list takeFast : Int -> Int -> List a -> List a takeFast ctr n list = - if n <= 0 then - [] - else - case ( n, list ) of - ( _, [] ) -> - list + if n <= 0 then + [] - ( 1, x :: _ ) -> - [ x ] + else + case ( n, list ) of + ( _, [] ) -> + list - ( 2, x :: y :: _ ) -> - [ x, y ] + ( 1, x :: _ ) -> + [ x ] - ( 3, x :: y :: z :: _ ) -> - [ x, y, z ] + ( 2, x :: y :: _ ) -> + [ x, y ] - ( _, x :: y :: z :: w :: tl ) -> - if ctr > 1000 then - cons x (cons y (cons z (cons w (takeTailRec (n - 4) tl)))) - else - cons x (cons y (cons z (cons w (takeFast (ctr + 1) (n - 4) tl)))) + ( 3, x :: y :: z :: _ ) -> + [ x, y, z ] + + ( _, x :: y :: z :: w :: tl ) -> + if ctr > 1000 then + cons x (cons y (cons z (cons w (takeTailRec (n - 4) tl)))) + + else + cons x (cons y (cons z (cons w (takeFast (ctr + 1) (n - 4) tl)))) + + _ -> + list - _ -> - list takeTailRec : Int -> List a -> List a takeTailRec n list = - reverse (takeReverse n list []) + reverse (takeReverse n list []) takeReverse : Int -> List a -> List a -> List a takeReverse n list kept = - if n <= 0 then - kept - else - case list of - [] -> + if n <= 0 then kept - x :: xs -> - takeReverse (n - 1) xs (cons x kept) + else + case list of + [] -> + kept + + x :: xs -> + takeReverse (n - 1) xs (cons x kept) + +{-| Drop the first _n_ members of a list. -{-| Drop the first *n* members of a list. + drop 2 [ 1, 2, 3, 4 ] == [ 3, 4 ] - drop 2 [1,2,3,4] == [3,4] -} drop : Int -> List a -> List a drop n list = - if n <= 0 then - list - - else - case list of - [] -> + if n <= 0 then list - x :: xs -> - drop (n-1) xs + else + case list of + [] -> + list + + x :: xs -> + drop (n - 1) xs {-| Partition a list based on some test. The first list contains all values that satisfy the test, and the second list contains all the value that do not. - partition (\x -> x < 3) [0,1,2,3,4,5] == ([0,1,2], [3,4,5]) - partition isEven [0,1,2,3,4,5] == ([0,2,4], [1,3,5]) + partition (\x -> x < 3) [ 0, 1, 2, 3, 4, 5 ] == ( [ 0, 1, 2 ], [ 3, 4, 5 ] ) + + partition isEven [ 0, 1, 2, 3, 4, 5 ] == ( [ 0, 2, 4 ], [ 1, 3, 5 ] ) + -} -partition : (a -> Bool) -> List a -> (List a, List a) +partition : (a -> Bool) -> List a -> ( List a, List a ) partition pred list = - let - step x (trues, falses) = - if pred x then - (cons x trues, falses) + let + step x ( trues, falses ) = + if pred x then + ( cons x trues, falses ) - else - (trues, cons x falses) - in - foldr step ([],[]) list + else + ( trues, cons x falses ) + in + foldr step ( [], [] ) list {-| Decompose a list of tuples into a tuple of lists. - unzip [(0, True), (17, False), (1337, True)] == ([0,17,1337], [True,False,True]) + unzip [ ( 0, True ), ( 17, False ), ( 1337, True ) ] == ( [ 0, 17, 1337 ], [ True, False, True ] ) + -} -unzip : List (a,b) -> (List a, List b) +unzip : List ( a, b ) -> ( List a, List b ) unzip pairs = - let - step (x,y) (xs,ys) = - (cons x xs, cons y ys) - in - foldr step ([], []) pairs + let + step ( x, y ) ( xs, ys ) = + ( cons x xs, cons y ys ) + in + foldr step ( [], [] ) pairs diff --git a/src/Maybe.elm b/src/Maybe.elm index 7cb5a5bf..5affd6d1 100644 --- a/src/Maybe.elm +++ b/src/Maybe.elm @@ -1,28 +1,32 @@ module Maybe exposing - ( Maybe(..) - , andThen - , map, map2, map3, map4, map5 - , withDefault - ) + ( Maybe(..) + , withDefault, map, map2, map3, map4, map5 + , andThen + ) {-| This library fills a bunch of important niches in Elm. A `Maybe` can help you with optional arguments, error handling, and records with optional fields. + # Definition + @docs Maybe + # Common Helpers + @docs withDefault, map, map2, map3, map4, map5 + # Chaining Maybes + @docs andThen --} +-} import Basics exposing (Bool(..)) - {-| Represent values that may or may not exist. It can be useful if you have a record field that is only filled in sometimes. Or if a function takes a value sometimes, but does not absolutely need it. @@ -33,8 +37,12 @@ sometimes, but does not absolutely need it. , age : Maybe Int } - tom = { name = "Tom", age = Just 42 } - sue = { name = "Sue", age = Nothing } + tom = + { name = "Tom", age = Just 42 } + + sue = + { name = "Sue", age = Nothing } + -} type Maybe a = Just a @@ -42,147 +50,159 @@ type Maybe a {-| Provide a default value, turning an optional value into a normal -value. This comes in handy when paired with functions like +value. This comes in handy when paired with functions like [`Dict.get`](Dict#get) which gives back a `Maybe`. - withDefault 100 (Just 42) -- 42 - withDefault 100 Nothing -- 100 + withDefault 100 (Just 42) -- 42 - withDefault "unknown" (Dict.get "Tom" Dict.empty) -- "unknown" + withDefault 100 Nothing -- 100 + + withDefault "unknown" (Dict.get "Tom" Dict.empty) -- "unknown" **Note:** This can be overused! Many cases are better handled by a `case` expression. And if you end up using `withDefault` a lot, it can be a good sign that a [custom type][ct] will clean your code up quite a bit! [ct]: https://guide.elm-lang.org/types/custom_types.html + -} withDefault : a -> Maybe a -> a withDefault default maybe = case maybe of - Just value -> value - Nothing -> default + Just value -> + value + + Nothing -> + default {-| Transform a `Maybe` value with a given function: map sqrt (Just 9) == Just 3 - map sqrt Nothing == Nothing + + map sqrt Nothing == Nothing map sqrt (String.toFloat "9") == Just 3 + map sqrt (String.toFloat "x") == Nothing -} map : (a -> b) -> Maybe a -> Maybe b map f maybe = - case maybe of - Just value -> - Just (f value) + case maybe of + Just value -> + Just (f value) - Nothing -> - Nothing + Nothing -> + Nothing {-| Apply a function if all the arguments are `Just` a value. map2 (+) (Just 3) (Just 4) == Just 7 + map2 (+) (Just 3) Nothing == Nothing + map2 (+) Nothing (Just 4) == Nothing map2 (+) (String.toInt "1") (String.toInt "123") == Just 124 + map2 (+) (String.toInt "x") (String.toInt "123") == Nothing + map2 (+) (String.toInt "1") (String.toInt "1.3") == Nothing + -} map2 : (a -> b -> value) -> Maybe a -> Maybe b -> Maybe value map2 func ma mb = - case ma of - Nothing -> - Nothing - - Just a -> - case mb of + case ma of Nothing -> - Nothing + Nothing + + Just a -> + case mb of + Nothing -> + Nothing - Just b -> - Just (func a b) + Just b -> + Just (func a b) -{-|-} +{-| -} map3 : (a -> b -> c -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe value map3 func ma mb mc = - case ma of - Nothing -> - Nothing - - Just a -> - case mb of + case ma of Nothing -> - Nothing + Nothing - Just b -> - case mc of - Nothing -> - Nothing + Just a -> + case mb of + Nothing -> + Nothing + + Just b -> + case mc of + Nothing -> + Nothing - Just c -> - Just (func a b c) + Just c -> + Just (func a b c) -{-|-} +{-| -} map4 : (a -> b -> c -> d -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe d -> Maybe value map4 func ma mb mc md = - case ma of - Nothing -> - Nothing - - Just a -> - case mb of + case ma of Nothing -> - Nothing - - Just b -> - case mc of - Nothing -> - Nothing + Nothing - Just c -> - case md of + Just a -> + case mb of Nothing -> - Nothing + Nothing + + Just b -> + case mc of + Nothing -> + Nothing - Just d -> - Just (func a b c d) + Just c -> + case md of + Nothing -> + Nothing + Just d -> + Just (func a b c d) -{-|-} + +{-| -} map5 : (a -> b -> c -> d -> e -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe d -> Maybe e -> Maybe value map5 func ma mb mc md me = - case ma of - Nothing -> - Nothing - - Just a -> - case mb of + case ma of Nothing -> - Nothing - - Just b -> - case mc of - Nothing -> - Nothing + Nothing - Just c -> - case md of + Just a -> + case mb of Nothing -> - Nothing + Nothing + + Just b -> + case mc of + Nothing -> + Nothing + + Just c -> + case md of + Nothing -> + Nothing - Just d -> - case me of - Nothing -> - Nothing + Just d -> + case me of + Nothing -> + Nothing - Just e -> - Just (func a b c d e) + Just e -> + Just (func a b c d e) {-| Chain together many computations that may fail. It is helpful to see its @@ -203,12 +223,13 @@ example, say you need to parse some user input as a month: parseMonth : String -> Maybe Int parseMonth userInput = String.toInt userInput - |> andThen toValidMonth + |> andThen toValidMonth toValidMonth : Int -> Maybe Int toValidMonth month = if 1 <= month && month <= 12 then Just month + else Nothing @@ -216,6 +237,7 @@ In the `parseMonth` function, if `String.toInt` produces `Nothing` (because the `userInput` was not an integer) this entire chain of operations will short-circuit and result in `Nothing`. If `toValidMonth` results in `Nothing`, again the chain of computations will result in `Nothing`. + -} andThen : (a -> Maybe b) -> Maybe a -> Maybe b andThen callback maybeValue = @@ -235,19 +257,19 @@ andThen callback maybeValue = isJust : Maybe a -> Bool isJust maybe = - case maybe of - Just _ -> - True + case maybe of + Just _ -> + True - Nothing -> - False + Nothing -> + False destruct : b -> (a -> b) -> Maybe a -> b destruct default func maybe = - case maybe of - Just a -> - func a + case maybe of + Just a -> + func a - Nothing -> - default + Nothing -> + default diff --git a/src/Platform.elm b/src/Platform.elm index fcefcab3..a1371bc3 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -1,60 +1,71 @@ module Platform exposing - ( Program, worker - , Task, ProcessId - , Router, sendToApp, sendToSelf - ) + ( Program, worker + , Task, ProcessId + , Router, sendToApp, sendToSelf + ) {-| + # Programs + @docs Program, worker + # Platform Internals + ## Tasks and Processes + @docs Task, ProcessId + ## Effect Manager Helpers An extremely tiny portion of library authors should ever write effect managers. Fundamentally, Elm needs maybe 10 of them total. I get that people are smart, curious, etc. but that is not a substitute for a legitimate reason to make an -effect manager. Do you have an *organic need* this fills? Or are you just +effect manager. Do you have an _organic need_ this fills? Or are you just curious? Public discussions of your explorations should be framed accordingly. @docs Router, sendToApp, sendToSelf + ## Unresolve questions -* Each app has a dict of effect managers, it also has a dict of "managers". - I have called these `OtherManagers` but what do they do and how shouuld they be named? + - Each app has a dict of effect managers, it also has a dict of "managers". + I have called these `OtherManagers` but what do they do and how shouuld they be named? -} +-- import Json.Decode exposing (Decoder) +-- import Json.Encode as Encode + import Basics exposing (..) +import Char exposing (Char) +import Debug +import Dict exposing (Dict) +import Elm.Kernel.Basics +import Elm.Kernel.Platform import List exposing ((::)) import Maybe exposing (Maybe(..)) +import Platform.Bag as Bag +import Platform.Cmd as Cmd exposing (Cmd) +import Platform.RawScheduler as RawScheduler +import Platform.Sub as Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) -import Char exposing (Char) import Tuple -import Debug -import Platform.Cmd as Cmd exposing ( Cmd ) -import Platform.Sub as Sub exposing ( Sub ) +type Decoder flags + = Decoder (Decoder flags) -import Elm.Kernel.Basics -import Elm.Kernel.Platform -import Platform.Bag as Bag --- import Json.Decode exposing (Decoder) --- import Json.Encode as Encode -import Dict exposing (Dict) -import Platform.RawScheduler as RawScheduler + +type EncodeValue + = EncodeValue EncodeValue -type Decoder flags = Decoder (Decoder flags) -type EncodeValue = EncodeValue EncodeValue -- PROGRAMS @@ -62,20 +73,23 @@ type EncodeValue = EncodeValue EncodeValue {-| A `Program` describes an Elm program! How does it react to input? Does it show anything on screen? Etc. -} -type Program flags model msg = - Program - ((Decoder flags) -> - DebugMetadata -> - RawJsObject { args: Maybe (RawJsObject flags) } -> - RawJsObject - { ports : RawJsObject - { outgoingPortName: OutgoingPort - , incomingPortName: IncomingPort - } - } - ) +type Program flags model msg + = Program + (Decoder flags + -> DebugMetadata + -> RawJsObject { args : Maybe (RawJsObject flags) } + -> + RawJsObject + { ports : + RawJsObject + { outgoingPortName : OutgoingPort + , incomingPortName : IncomingPort + } + } + ) -{-| Create a [headless][] program with no user interface. + +{-| Create a [headless] program with no user interface. This is great if you want to use Elm as the “brain” for something else. For example, you could send messages out ports to modify the DOM, but do @@ -94,30 +108,30 @@ module has a few ways to create that kind of `Program` instead! [headless]: https://en.wikipedia.org/wiki/Headless_software [browser]: /packages/elm/browser/latest/Browser + -} -worker - : { init : flags -> ( model, Cmd msg ) +worker : + { init : flags -> ( model, Cmd msg ) , update : msg -> model -> ( model, Cmd msg ) , subscriptions : model -> Sub msg } - -> Program flags model msg + -> Program flags model msg worker impl = - makeProgramCallable - (Program - (\flagsDecoder _ args -> - initialize - flagsDecoder - args - impl - { stepperBuilder = \ _ _ -> (\ _ _ -> ()) - , setupOutgoingPort = setupOutgoingPort - , setupIncomingPort = setupIncomingPort - , setupEffects = instantiateEffectManager - , dispatchEffects = dispatchEffects - } - ) - ) - + makeProgramCallable + (Program + (\flagsDecoder _ args -> + initialize + flagsDecoder + args + impl + { stepperBuilder = \_ _ -> \_ _ -> () + , setupOutgoingPort = setupOutgoingPort + , setupIncomingPort = setupIncomingPort + , setupEffects = instantiateEffectManager + , dispatchEffects = dispatchEffects + } + ) + ) @@ -129,17 +143,15 @@ information on this. It is only defined here because it is a platform primitive. -} type Task err ok - = Task - (RawScheduler.Task (Result err ok)) + = Task (RawScheduler.Task (Result err ok)) {-| Head over to the documentation for the [`Process`](Process) module for information on this. It is only defined here because it is a platform primitive. -} -type ProcessId = - ProcessId - (RawScheduler.ProcessId Never) +type ProcessId + = ProcessId (RawScheduler.ProcessId Never) @@ -150,10 +162,10 @@ type ProcessId = the main app and your individual effect manager. -} type Router appMsg selfMsg - = Router - { sendToApp: appMsg -> () - , selfProcess: RawScheduler.ProcessId (ReceivedData appMsg selfMsg) - } + = Router + { sendToApp : appMsg -> () + , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + } {-| Send the router a message for the main loop of your app. This message will @@ -161,12 +173,12 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Task - (RawScheduler.SyncAction - (\() -> - RawScheduler.Value (Ok (router.sendToApp msg)) - ) - ) + Task + (RawScheduler.SyncAction + (\() -> + RawScheduler.Value (Ok (router.sendToApp msg)) + ) + ) {-| Send the router a message for your effect manager. This message will @@ -174,17 +186,19 @@ be routed to the `onSelfMsg` function, where you can update the state of your effect manager as necessary. As an example, the effect manager for web sockets + -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.send - router.selfProcess - (Self msg) - ) - ) + Task + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.send + router.selfProcess + (Self msg) + ) + ) + -- HELPERS -- @@ -192,277 +206,291 @@ sendToSelf (Router router) msg = setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = - let - init = - Task (RawScheduler.Value (Ok ())) - - onSelfMsg _ selfMsg () = - never selfMsg - - execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) - execInOrder cmdList = - case cmdList of - first :: rest -> - RawScheduler.SyncAction (\() -> + let + init = + Task (RawScheduler.Value (Ok ())) + + onSelfMsg _ selfMsg () = + never selfMsg + + execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) + execInOrder cmdList = + case cmdList of + first :: rest -> + RawScheduler.SyncAction + (\() -> + let + _ = + outgoingPortSend first + in + execInOrder rest + ) + + _ -> + RawScheduler.Value (Ok ()) + + onEffects : + Router msg selfMsg + -> List (HiddenMyCmd msg) + -> List (HiddenMySub msg) + -> () + -> Task Never () + onEffects _ cmdList _ () = let - _ = outgoingPortSend first + typedCmdList : List EncodeValue + typedCmdList = + Elm.Kernel.Basics.fudgeType cmdList in - execInOrder rest - ) - - _ -> - RawScheduler.Value (Ok ()) - - onEffects : Router msg selfMsg - -> List (HiddenMyCmd msg) - -> List (HiddenMySub msg) - -> () - -> Task Never () - onEffects _ cmdList _ () = - let - typedCmdList : List EncodeValue - typedCmdList = - Elm.Kernel.Basics.fudgeType cmdList - in - Task (execInOrder typedCmdList) - - in - instantiateEffectManager (\msg -> never msg) init onEffects onSelfMsg - - -setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> (RawScheduler.ProcessId (ReceivedData msg Never), msg -> List (HiddenMySub msg) -> ()) -setupIncomingPort sendToApp2 updateSubs = - let - init = - Task (RawScheduler.Value (Ok ())) + Task (execInOrder typedCmdList) + in + instantiateEffectManager (\msg -> never msg) init onEffects onSelfMsg - onSelfMsg _ selfMsg () = - never selfMsg - onEffects _ _ subList () = - Task - (RawScheduler.SyncAction - (\() -> - let - _ = updateSubs subList - in - RawScheduler.Value (Ok ()) - ) - ) +setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> ( RawScheduler.ProcessId (ReceivedData msg Never), msg -> List (HiddenMySub msg) -> () ) +setupIncomingPort sendToApp2 updateSubs = + let + init = + Task (RawScheduler.Value (Ok ())) + + onSelfMsg _ selfMsg () = + never selfMsg + + onEffects _ _ subList () = + Task + (RawScheduler.SyncAction + (\() -> + let + _ = + updateSubs subList + in + RawScheduler.Value (Ok ()) + ) + ) + + onSend : msg -> List (HiddenMySub msg) -> () + onSend value subs = + List.foldr + (\sub () -> + let + typedSub : msg -> msg + typedSub = + Elm.Kernel.Basics.fudgeType sub + in + sendToApp2 (typedSub value) AsyncUpdate + ) + () + subs + in + ( instantiateEffectManager sendToApp2 init onEffects onSelfMsg + , onSend + ) - onSend : msg -> List (HiddenMySub msg) -> () - onSend value subs = - List.foldr - (\sub () -> - let - typedSub : msg -> msg - typedSub = - Elm.Kernel.Basics.fudgeType sub - in - sendToApp2 (typedSub value) AsyncUpdate - ) - () - subs - in - ( instantiateEffectManager sendToApp2 init onEffects onSelfMsg - , onSend - ) - - -dispatchEffects : Cmd appMsg - -> Sub appMsg - -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) - -> () + +dispatchEffects : + Cmd appMsg + -> Sub appMsg + -> Bag.EffectManagerName + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> () dispatchEffects cmdBag subBag = - let - effectsDict = - Dict.empty - |> gatherCmds cmdBag - |> gatherSubs subBag - in - \key selfProcess-> - let - (cmdList, subList) = - Maybe.withDefault - ([], []) - (Dict.get (effectManagerNameToString key) effectsDict) - - - _ = - RawScheduler.rawSend - selfProcess - (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) - in + let + effectsDict = + Dict.empty + |> gatherCmds cmdBag + |> gatherSubs subBag + in + \key selfProcess -> + let + ( cmdList, subList ) = + Maybe.withDefault + ( [], [] ) + (Dict.get (effectManagerNameToString key) effectsDict) + + _ = + RawScheduler.rawSend + selfProcess + (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) + in () -gatherCmds : Cmd msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherCmds : Cmd msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) gatherCmds cmdBag effectsDict = - List.foldr - (\{home, value} dict -> gatherHelper True home value dict) - effectsDict - (unwrapCmd cmdBag) + List.foldr + (\{ home, value } dict -> gatherHelper True home value dict) + effectsDict + (unwrapCmd cmdBag) -gatherSubs : Sub msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherSubs : Sub msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) gatherSubs subBag effectsDict = - List.foldr - (\{home, value} dict -> gatherHelper False home value dict) - effectsDict - (unwrapSub subBag) + List.foldr + (\{ home, value } dict -> gatherHelper False home value dict) + effectsDict + (unwrapSub subBag) -gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> Dict String (List (Bag.LeafType msg), List (Bag.LeafType msg)) +gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) gatherHelper isCmd home effectData effectsDict = Dict.insert - (effectManagerNameToString home) - (createEffect isCmd effectData (Dict.get (effectManagerNameToString home) effectsDict)) - effectsDict + (effectManagerNameToString home) + (createEffect isCmd effectData (Dict.get (effectManagerNameToString home) effectsDict)) + effectsDict -createEffect : Bool -> Bag.LeafType msg -> Maybe (List (Bag.LeafType msg), List (Bag.LeafType msg)) -> (List (Bag.LeafType msg), List (Bag.LeafType msg)) +createEffect : Bool -> Bag.LeafType msg -> Maybe ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) createEffect isCmd newEffect maybeEffects = - let - (cmdList, subList) = - case maybeEffects of - Just effects -> effects - Nothing -> ([], []) - in - if isCmd then - (newEffect :: cmdList, subList) - else - (cmdList, newEffect :: subList) - - -instantiateEffectManager : SendToApp appMsg - -> Task Never state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) - -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + let + ( cmdList, subList ) = + case maybeEffects of + Just effects -> + effects + + Nothing -> + ( [], [] ) + in + if isCmd then + ( newEffect :: cmdList, subList ) + + else + ( cmdList, newEffect :: subList ) + + +instantiateEffectManager : + SendToApp appMsg + -> Task Never state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) + -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = - let - receiver msg stateRes = - let - (Task task) = - case stateRes of - Ok state -> - case msg of - Self value -> - onSelfMsg router value state - - App cmds subs -> - onEffects router cmds subs state - - Err e -> - never e - - in - RawScheduler.andThen - (\res -> - case res of - Ok val -> - RawScheduler.andThen - (\() -> RawScheduler.Value (Ok val)) - (RawScheduler.sleep 0) - - Err e -> - never e - ) - task - - - selfProcessInitRoot = - RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) - - selfProcessId = - RawScheduler.newProcessId () - - router = - Router - { sendToApp = (\appMsg -> sendToAppFunc appMsg AsyncUpdate) - , selfProcess = selfProcessId - } - in - RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId + let + receiver msg stateRes = + let + (Task task) = + case stateRes of + Ok state -> + case msg of + Self value -> + onSelfMsg router value state + + App cmds subs -> + onEffects router cmds subs state + + Err e -> + never e + in + RawScheduler.andThen + (\res -> + case res of + Ok val -> + RawScheduler.andThen + (\() -> RawScheduler.Value (Ok val)) + (RawScheduler.sleep 0) + + Err e -> + never e + ) + task + + selfProcessInitRoot = + RawScheduler.andThen + (\() -> init) + (RawScheduler.sleep 0) + + selfProcessId = + RawScheduler.newProcessId () + + router = + Router + { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate + , selfProcess = selfProcessId + } + in + RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId type alias SendToApp msg = - msg -> UpdateMetadata -> () + msg -> UpdateMetadata -> () type alias StepperBuilder model msg = - SendToApp msg -> model -> (SendToApp msg) + SendToApp msg -> model -> SendToApp msg -type alias DebugMetadata = EncodeValue +type alias DebugMetadata = + EncodeValue {-| AsyncUpdate is default I think TODO(harry) understand this by reading source of VirtualDom + -} type UpdateMetadata - = SyncUpdate - | AsyncUpdate + = SyncUpdate + | AsyncUpdate -type OtherManagers appMsg = - OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) +type OtherManagers appMsg + = OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) type ReceivedData appMsg selfMsg - = Self selfMsg - | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) + = Self selfMsg + | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) -type OutgoingPort = - OutgoingPort - { subscribe: (EncodeValue -> ()) - , unsubscribe: (EncodeValue -> ()) - } +type OutgoingPort + = OutgoingPort + { subscribe : EncodeValue -> () + , unsubscribe : EncodeValue -> () + } -type IncomingPort = - IncomingPort - { send: (EncodeValue -> ()) - } +type IncomingPort + = IncomingPort + { send : EncodeValue -> () + } + type HiddenTypeA - = HiddenTypeA Never + = HiddenTypeA Never + type HiddenTypeB - = HiddenTypeB Never + = HiddenTypeB Never -type HiddenMyCmd msg = HiddenMyCmd (Bag.LeafType msg) +type HiddenMyCmd msg + = HiddenMyCmd (Bag.LeafType msg) -type HiddenMySub msg = HiddenMySub (Bag.LeafType msg) +type HiddenMySub msg + = HiddenMySub (Bag.LeafType msg) -type HiddenSelfMsg = HiddenSelfMsg HiddenSelfMsg +type HiddenSelfMsg + = HiddenSelfMsg HiddenSelfMsg -type HiddenState = HiddenState HiddenState +type HiddenState + = HiddenState HiddenState type RawJsObject record - = JsRecord (RawJsObject record) - | JsAny + = JsRecord (RawJsObject record) + | JsAny type alias Impl flags model msg = - { init : flags -> ( model, Cmd msg ) - , update : msg -> model -> ( model, Cmd msg ) - , subscriptions : model -> Sub msg - } + { init : flags -> ( model, Cmd msg ) + , update : msg -> model -> ( model, Cmd msg ) + , subscriptions : model -> Sub msg + } type alias SetupEffects state appMsg selfMsg = - SendToApp appMsg + SendToApp appMsg -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) @@ -470,45 +498,50 @@ type alias SetupEffects state appMsg selfMsg = type alias InitFunctions model appMsg = - { stepperBuilder : SendToApp appMsg -> model -> (SendToApp appMsg) - , setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) - , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> (RawScheduler.ProcessId (ReceivedData appMsg Never), appMsg -> List (HiddenMySub appMsg) -> ()) - , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg - , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () - } + { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg + , setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) + , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), appMsg -> List (HiddenMySub appMsg) -> () ) + , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg + , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () + } + + -- kernel -- + initialize : - Decoder flags -> - RawJsObject { args: Maybe (RawJsObject flags) } -> - Impl flags model msg -> - InitFunctions model msg -> - RawJsObject - { ports : RawJsObject - { outgoingPortName: OutgoingPort - , incomingPortName: IncomingPort - } - } + Decoder flags + -> RawJsObject { args : Maybe (RawJsObject flags) } + -> Impl flags model msg + -> InitFunctions model msg + -> + RawJsObject + { ports : + RawJsObject + { outgoingPortName : OutgoingPort + , incomingPortName : IncomingPort + } + } initialize = - Elm.Kernel.Platform.initialize + Elm.Kernel.Platform.initialize -makeProgramCallable : Program flags model msg -> Program flags model msg +makeProgramCallable : Program flags model msg -> Program flags model msg makeProgramCallable (Program program) = - Elm.Kernel.Basics.fudgeType program + Elm.Kernel.Basics.fudgeType program effectManagerNameToString : Bag.EffectManagerName -> String effectManagerNameToString = - Elm.Kernel.Platform.effectManagerNameToString + Elm.Kernel.Platform.effectManagerNameToString unwrapCmd : Cmd a -> Bag.EffectBag a unwrapCmd = - Elm.Kernel.Basics.unwrapTypeWrapper + Elm.Kernel.Basics.unwrapTypeWrapper unwrapSub : Sub a -> Bag.EffectBag a unwrapSub = - Elm.Kernel.Basics.unwrapTypeWrapper + Elm.Kernel.Basics.unwrapTypeWrapper diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm index 86c5c1c4..e88fcc93 100644 --- a/src/Platform/Bag.elm +++ b/src/Platform/Bag.elm @@ -1,21 +1,24 @@ module Platform.Bag exposing - ( LeafType - , EffectManagerName - , EffectBag - ) + ( EffectBag + , EffectManagerName + , LeafType + ) type alias EffectBag msg = - List - { home : EffectManagerName - , value : (LeafType msg) - } + List + { home : EffectManagerName + , value : LeafType msg + } -type LeafType msg = LeafType Kernel +type LeafType msg + = LeafType Kernel -type EffectManagerName = EffectManagerName Kernel +type EffectManagerName + = EffectManagerName Kernel -type Kernel = Kernel Kernel +type Kernel + = Kernel Kernel diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index bcfa0a8d..196f297f 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -1,14 +1,12 @@ module Platform.Cmd exposing - ( Cmd - , none - , batch - , map - ) + ( Cmd, none, batch + , map + ) {-| > **Note:** Elm has **managed effects**, meaning that things like HTTP -> requests or writing to disk are all treated as *data* in Elm. When this +> requests or writing to disk are all treated as _data_ in Elm. When this > data is given to the Elm runtime system, it can do some “query optimization” > before actually performing the effect. Perhaps unexpectedly, this managed > effects idea is the heart of why Elm is so nice for testing, reuse, @@ -16,16 +14,20 @@ module Platform.Cmd exposing > > Elm has two kinds of managed effects: commands and subscriptions. + # Commands + @docs Cmd, none, batch + # Fancy Stuff + @docs map -} -import Elm.Kernel.Basics import Basics exposing (..) +import Elm.Kernel.Basics import List import Platform.Bag as Bag @@ -46,16 +48,17 @@ messages that will come back into your application. ever, commands will make more sense as you work through [the Elm Architecture Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! + -} type Cmd msg - = Data (Bag.EffectBag msg) + = Data (Bag.EffectBag msg) -{-| Tell the runtime that there are no commands. +{-| Tell the runtime that there are no commands. -} none : Cmd msg none = - batch [] + batch [] {-| When you need the runtime system to perform a couple commands, you @@ -65,12 +68,14 @@ no ordering guarantees about the results. **Note:** `Cmd.none` and `Cmd.batch [ Cmd.none, Cmd.none ]` and `Cmd.batch []` all do the same thing. + -} batch : List (Cmd msg) -> Cmd msg batch = - List.map (\(Data cmd) -> cmd) - >> List.concat - >> Data + List.map (\(Data cmd) -> cmd) + >> List.concat + >> Data + -- FANCY STUFF @@ -80,20 +85,22 @@ batch = Very similar to [`Html.map`](/packages/elm/html/latest/Html#map). This is very rarely useful in well-structured Elm code, so definitely read the -section on [structure][] in the guide before reaching for this! +section on [structure] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html + -} map : (a -> msg) -> Cmd a -> Cmd msg map fn (Data data) = - data - |> List.map - (\{home, value} -> - { home = home - , value = (getCmdMapper home) fn value - } - ) - |> Data + data + |> List.map + (\{ home, value } -> + { home = home + , value = getCmdMapper home fn value + } + ) + |> Data + -- Kernel function redefinitons -- @@ -101,4 +108,4 @@ map fn (Data data) = getCmdMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg getCmdMapper = - Elm.Kernel.Platform.getCmdMapper + Elm.Kernel.Platform.getCmdMapper diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 4e6bd6b3..66a12e51 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -2,91 +2,95 @@ module Platform.RawScheduler exposing (..) {-| + ## Module notes: -* Types called `HiddenXXX` are used to bypass the elm type system. + - Types called `HiddenXXX` are used to bypass the elm type system. The programmer takes **full responsibiliy** for making sure that the types line up. That does mean you have to second guess any and all strange - decisions I have made, hopefully things will get clearer over + decisions I have made, hopefully things will get clearer over time. -- The `Binding` constructor on the `Task` type is tricky one. - + It contains a callback function (that we will call `doEffect`) - and a `killer` function. `doEffect` will be called by - `Scheduler.enqueue` and will be passed another callback. - We call this second callback `doneCallback`. - `doEffect` should do its effects (which may be impure) and then, - when it is done, call `doneCallback`.`doEffect` **must** call - `doneCallback` and it **must** pass `doneCallback` a - `Task ErrX OkX` as an argument. (I am unsure about the values of - ErrX and OkX at the moment). The return value of `doEffect` may - be either `undefined` or a function that cancels the effect. - + If the second value `killer` is not Nothing, then the runtime - will call it if the execution of the `Task` should be aborted. + - The `Binding` constructor on the `Task` type is tricky one. + - It contains a callback function (that we will call `doEffect`) + and a `killer` function. `doEffect` will be called by + `Scheduler.enqueue` and will be passed another callback. + We call this second callback `doneCallback`. + `doEffect` should do its effects (which may be impure) and then, + when it is done, call `doneCallback`.`doEffect` **must** call + `doneCallback` and it **must** pass `doneCallback` a + `Task ErrX OkX` as an argument. (I am unsure about the values of + ErrX and OkX at the moment). The return value of `doEffect` may + be either `undefined` or a function that cancels the effect. + - If the second value `killer` is not Nothing, then the runtime + will call it if the execution of the `Task` should be aborted. ## Differences between this and offical elm/core -* `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. -* `Process.stack` is an (immutable) js linked list in elm/core and an elm list here. -* `Elm.Kernel.Scheduler.rawSend` mutates the process before enqueuing it in elm/core. + - `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. + - `Process.stack` is an (immutable) js linked list in elm/core and an elm list here. + - `Elm.Kernel.Scheduler.rawSend` mutates the process before enqueuing it in elm/core. Here we create a **new** process with the **same** (unique) id and then enqueue it. Same applies for (non-raw) `send`. -} import Basics exposing (..) -import Maybe exposing (Maybe(..)) +import Debug import Elm.Kernel.Basics import Elm.Kernel.Scheduler import List exposing ((::)) -import Debug +import Maybe exposing (Maybe(..)) + type Task val - = Value val - | AsyncAction (DoneCallback val -> TryAbortAction) - | SyncAction (() -> Task val) + = Value val + | AsyncAction (DoneCallback val -> TryAbortAction) + | SyncAction (() -> Task val) + type alias DoneCallback val = - Task val -> () + Task val -> () type alias TryAbortAction = - () -> () + () -> () type ProcessRoot state - = Ready (Task state) - | Running TryAbortAction + = Ready (Task state) + | Running TryAbortAction type ProcessState msg state - = ProcessState (ProcessRoot state) + = ProcessState (ProcessRoot state) type ProcessId msg - = ProcessId { id: UniqueId } + = ProcessId { id : UniqueId } -type UniqueId = UniqueId UniqueId +type UniqueId + = UniqueId UniqueId andThen : (a -> Task b) -> Task a -> Task b andThen func task = - case task of - Value val -> - func val - - SyncAction thunk -> - SyncAction (\() -> andThen func (thunk ())) - - AsyncAction doEffect -> - AsyncAction - (\doneCallback -> - doEffect - (\newTask -> doneCallback (andThen func newTask)) - ) + case task of + Value val -> + func val + + SyncAction thunk -> + SyncAction (\() -> andThen func (thunk ())) + + AsyncAction doEffect -> + AsyncAction + (\doneCallback -> + doEffect + (\newTask -> doneCallback (andThen func newTask)) + ) {-| Create a new, unique, process id. @@ -101,22 +105,22 @@ may even fail silently in optimized compiles.) -} newProcessId : () -> ProcessId msg newProcessId () = - ProcessId { id = Elm.Kernel.Scheduler.getGuid() } + ProcessId { id = Elm.Kernel.Scheduler.getGuid () } {-| NON PURE! -Will create, register and **enqueue** a new process. +Will create, register and **enqueue** a new process. -} rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg rawSpawn receiver initTask processId = - enqueue - (registerNewProcess - processId - receiver - (ProcessState (Ready initTask)) - ) + enqueue + (registerNewProcess + processId + receiver + (ProcessState (Ready initTask)) + ) {-| NON PURE! @@ -130,10 +134,10 @@ mailbox. -} rawSend : ProcessId msg -> msg -> ProcessId msg rawSend processId msg = - let - _ = - mailboxAdd msg processId - in + let + _ = + mailboxAdd msg processId + in enqueue processId @@ -141,56 +145,57 @@ rawSend processId msg = -} send : ProcessId msg -> msg -> Task () send processId msg = - SyncAction - (\() -> - let - (ProcessId _) = - rawSend processId msg - in - Value () - ) + SyncAction + (\() -> + let + (ProcessId _) = + rawSend processId msg + in + Value () + ) {-| Create a task that spawns a processes. -} spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) spawn receiver task = - SyncAction - (\() -> Value (rawSpawn receiver task (newProcessId ()))) + SyncAction + (\() -> Value (rawSpawn receiver task (newProcessId ()))) {-| Create a task that sleeps for `time` milliseconds -} sleep : Float -> Task () sleep time = - AsyncAction (delay time (Value ())) + AsyncAction (delay time (Value ())) {-| Create a task kills a process. - To kill a process we should try to abort any ongoing async action. - We only allow processes that cannot receive messages to be killed, we will - on the offical core library to lead the way regarding processes that can - receive values. +To kill a process we should try to abort any ongoing async action. +We only allow processes that cannot receive messages to be killed, we will +on the offical core library to lead the way regarding processes that can +receive values. + -} kill : ProcessId Never -> Task () kill processId = - SyncAction - (\() -> - let - (ProcessState root) = - getProcessState processId - - () = - case root of - Running killer -> - killer () - - Ready _ -> - () - in - Value () - ) + SyncAction + (\() -> + let + (ProcessState root) = + getProcessState processId + + () = + case root of + Running killer -> + killer () + + Ready _ -> + () + in + Value () + ) {-| NON PURE! @@ -202,69 +207,71 @@ Returns the enqueued `Process`. -} enqueue : ProcessId msg -> ProcessId msg enqueue id = - enqueueWithStepper - (\procId -> - let - onAsyncActionDone = - runOnNextTick - (\newRoot -> - let - (ProcessState (_)) = - (updateProcessState - (\(ProcessState p) -> - ProcessState (Ready newRoot) - ) - procId - ) - in - let - (ProcessId _) = - enqueue procId - in - () - ) + enqueueWithStepper + (\procId -> + let + onAsyncActionDone = + runOnNextTick + (\newRoot -> + let + (ProcessState _) = + updateProcessState + (\(ProcessState p) -> + ProcessState (Ready newRoot) + ) + procId + in + let + (ProcessId _) = + enqueue procId + in + () + ) + + (ProcessState _) = + updateProcessState (stepper procId onAsyncActionDone) procId + in + () + ) + id - (ProcessState _) = - updateProcessState (stepper procId onAsyncActionDone) procId - in - () - ) - id -- Helper functions -- + {-| NON PURE! (calls enqueue) This function **must** return a process with the **same ID** as -the process it is passed as an argument +the process it is passed as an argument -} stepper : ProcessId msg -> (Task state -> ()) -> ProcessState msg state -> ProcessState msg state stepper processId onAsyncActionDone (ProcessState process) = - case process of - Running _ -> - (ProcessState process) - - Ready (Value val) -> - case mailboxReceive processId val of - Just newRoot -> - stepper - processId - onAsyncActionDone - (ProcessState (Ready newRoot)) + case process of + Running _ -> + ProcessState process + + Ready (Value val) -> + case mailboxReceive processId val of + Just newRoot -> + stepper + processId + onAsyncActionDone + (ProcessState (Ready newRoot)) + + Nothing -> + ProcessState process - Nothing -> - ProcessState process + Ready (AsyncAction doEffect) -> + ProcessState (Running (doEffect onAsyncActionDone)) - Ready (AsyncAction doEffect) -> - ProcessState (Running (doEffect onAsyncActionDone)) + Ready (SyncAction doEffect) -> + stepper + processId + onAsyncActionDone + (ProcessState (Ready (doEffect ()))) - Ready (SyncAction doEffect) -> - stepper - processId - onAsyncActionDone - (ProcessState (Ready (doEffect ()))) -- Kernel function redefinitons -- @@ -272,39 +279,39 @@ stepper processId onAsyncActionDone (ProcessState process) = updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state updateProcessState = - Elm.Kernel.Scheduler.updateProcessState + Elm.Kernel.Scheduler.updateProcessState mailboxAdd : msg -> ProcessId msg -> msg mailboxAdd = - Elm.Kernel.Scheduler.mailboxAdd + Elm.Kernel.Scheduler.mailboxAdd mailboxReceive : ProcessId msg -> state -> Maybe (Task state) mailboxReceive = - Elm.Kernel.Scheduler.mailboxReceive + Elm.Kernel.Scheduler.mailboxReceive getProcessState : ProcessId msg -> ProcessState msg state getProcessState = - Elm.Kernel.Scheduler.getProcessState + Elm.Kernel.Scheduler.getProcessState registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg registerNewProcess = - Elm.Kernel.Scheduler.registerNewProcess + Elm.Kernel.Scheduler.registerNewProcess enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg enqueueWithStepper = - Elm.Kernel.Scheduler.enqueueWithStepper + Elm.Kernel.Scheduler.enqueueWithStepper delay : Float -> Task val -> DoneCallback val -> TryAbortAction delay = - Elm.Kernel.Scheduler.delay + Elm.Kernel.Scheduler.delay runOnNextTick : (a -> ()) -> a -> () runOnNextTick = - Elm.Kernel.Scheduler.runOnNextTick + Elm.Kernel.Scheduler.runOnNextTick diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index c51eb84f..222f2e99 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,42 +1,39 @@ module Platform.Scheduler exposing (..) -{-| - -The definition of the `Task` and `ProcessId` really belong in the +{-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. -1. Tasks and processes are created, run and managed by the scheduler. It makes - semantic sense for the scheduler to also contain the type defintion. -2. The `Platform.RawScheduler` module is private to `elm/core`, therefore other - core functions could access the type constructurs if they were contained - within the module. `Platform` is a public module and therefore we cannot - expose the type constructures to core functions without also exposing them - to user functions. +1. Tasks and processes are created, run and managed by the scheduler. It makes + semantic sense for the scheduler to also contain the type defintion. +2. The `Platform.RawScheduler` module is private to `elm/core`, therefore other + core functions could access the type constructurs if they were contained + within the module. `Platform` is a public module and therefore we cannot + expose the type constructures to core functions without also exposing them + to user functions. However, for two reasons they must instead be defined in the `Platform` module. -1. The official elm compiler regards changing a type definition to a type alias - to be a MAJOR change. Moving the type definition out of `Platform` and - replacing it with a type alias would count as a MAJOR change. As one of my - aims for this alternative elm/core library was no MAJOR (or even MINOR - changes) according to elm diff. Moving `Task` and `ProcessId` out of - `Platform` would defeat this aim. -2. More seriously, there are hard coded checks in the elm compiler ensuring - effect modules are valid. The compiler checks that the module defines the - needed functions (for example `onEffects`, `onSelfMsg`, etc) but it also - checks that the type signatures of these functions are correct. If we - replace the type definitions in `Platform` by type aliases all these checks - start to fail. For example, the compile checks that `Task.onEffects` returns - a `Platform.Task` but actually it returns `Platform.RawScheduler.Task` (via - a type alias in `Platform` but type aliases are transparent to the compiler - at this point during compiliation). +1. The official elm compiler regards changing a type definition to a type alias + to be a MAJOR change. Moving the type definition out of `Platform` and + replacing it with a type alias would count as a MAJOR change. As one of my + aims for this alternative elm/core library was no MAJOR (or even MINOR + changes) according to elm diff. Moving `Task` and `ProcessId` out of + `Platform` would defeat this aim. +2. More seriously, there are hard coded checks in the elm compiler ensuring + effect modules are valid. The compiler checks that the module defines the + needed functions (for example `onEffects`, `onSelfMsg`, etc) but it also + checks that the type signatures of these functions are correct. If we + replace the type definitions in `Platform` by type aliases all these checks + start to fail. For example, the compile checks that `Task.onEffects` returns + a `Platform.Task` but actually it returns `Platform.RawScheduler.Task` (via + a type alias in `Platform` but type aliases are transparent to the compiler + at this point during compiliation). In an attempt to get the best of both worlds we define `Task` and `ProcessId` types in `Platform.RawScheduler` and then in `Platform` we define -```elm -type Task error value = Task (Platform.RawScheduler.Task (Result error value)) -``` + type Task error value + = Task (Platform.RawScheduler.Task (Result error value)) This module provides functions that work with `Platform.Task`s and `Platform.ProcessId`s. However, as the type constructors are not exposed (if @@ -45,165 +42,168 @@ to some kernel code magic to wrap and unwrap `Task`s and `Process`s. -} +import Basics exposing (..) +import Elm.Kernel.Basics +import Elm.Kernel.Platform import Platform import Platform.RawScheduler as RawScheduler -import Elm.Kernel.Platform -import Elm.Kernel.Basics import Result exposing (Result(..)) -import Basics exposing (..) -type alias ProcessId msg - = RawScheduler.ProcessId msg +type alias ProcessId msg = + RawScheduler.ProcessId msg + type alias DoneCallback err ok = - Platform.Task err ok -> () + Platform.Task err ok -> () type alias TryAbortAction = - RawScheduler.TryAbortAction + RawScheduler.TryAbortAction succeed : ok -> Platform.Task never ok succeed val = - wrapTask (RawScheduler.Value (Ok val)) + wrapTask (RawScheduler.Value (Ok val)) fail : err -> Platform.Task err never fail e = - wrapTask (RawScheduler.Value (Err e)) + wrapTask (RawScheduler.Value (Err e)) binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok binding callback = - wrapTask - (RawScheduler.AsyncAction - (\doneCallback -> callback (taskFn (\task -> doneCallback task))) - ) + wrapTask + (RawScheduler.AsyncAction + (\doneCallback -> callback (taskFn (\task -> doneCallback task))) + ) andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 andThen func = - wrapTaskFn (\task -> - (RawScheduler.andThen - (\r -> - case r of - Ok val -> - unwrapTask (func val) + wrapTaskFn + (\task -> + RawScheduler.andThen + (\r -> + case r of + Ok val -> + unwrapTask (func val) - Err e -> - RawScheduler.Value (Err e) - ) - task - ) - ) + Err e -> + RawScheduler.Value (Err e) + ) + task + ) onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok -onError func = - wrapTaskFn (\task -> - (RawScheduler.andThen - (\r -> - case r of - Ok val -> - RawScheduler.Value (Ok val) - - Err e -> - unwrapTask (func e) - ) - task - ) - ) +onError func = + wrapTaskFn + (\task -> + RawScheduler.andThen + (\r -> + case r of + Ok val -> + RawScheduler.Value (Ok val) + + Err e -> + unwrapTask (func e) + ) + task + ) {-| Create a task, if run, will make the process deal with a message. -} send : ProcessId msg -> msg -> Platform.Task never () send proc msg = - wrapTask - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.send proc msg) - ) + wrapTask + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.send proc msg) + ) {-| Create a task that, when run, will spawn a process. There is no way to send messages to a process spawned in this way. + -} spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId spawn = - wrapTaskFn (\task -> - (RawScheduler.andThen - (\proc -> RawScheduler.Value (Ok (wrapProcessId proc))) - (RawScheduler.spawn (\msg state -> never msg) task) - ) - ) - + wrapTaskFn + (\task -> + RawScheduler.andThen + (\proc -> RawScheduler.Value (Ok (wrapProcessId proc))) + (RawScheduler.spawn (\msg state -> never msg) task) + ) -{-| This is provided to make __Schdeuler_rawSpawn work! +{-| This is provided to make \_\_Schdeuler\_rawSpawn work! TODO(harry) remove once code in other `elm/*` packages has been updated. + -} rawSpawn : Platform.Task err ok -> Platform.ProcessId rawSpawn = - taskFn (\task -> - wrapProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task (RawScheduler.newProcessId ())) - ) - + taskFn + (\task -> + wrapProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task (RawScheduler.newProcessId ())) + ) {-| Create a task kills a process. -} kill : Platform.ProcessId -> Platform.Task never () kill processId = - wrapTask - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.kill (unwrapProcessId processId)) - ) + wrapTask + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.kill (unwrapProcessId processId)) + ) {-| Create a task that sleeps for `time` milliseconds -} sleep : Float -> Platform.Task x () sleep time = - wrapTask - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.sleep time) - ) + wrapTask + (RawScheduler.andThen + (\() -> RawScheduler.Value (Ok ())) + (RawScheduler.sleep time) + ) + -- wrapping helpers -- -wrapTaskFn: (RawScheduler.Task (Result e1 o1) -> RawScheduler.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 +wrapTaskFn : (RawScheduler.Task (Result e1 o1) -> RawScheduler.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 wrapTaskFn fn task = - wrapTask (taskFn fn task) + wrapTask (taskFn fn task) -taskFn: (RawScheduler.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a +taskFn : (RawScheduler.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a taskFn fn task = - fn (unwrapTask task) + fn (unwrapTask task) -wrapTask: (RawScheduler.Task (Result e o)) -> Platform.Task e o +wrapTask : RawScheduler.Task (Result e o) -> Platform.Task e o wrapTask = - Elm.Kernel.Platform.wrapTask + Elm.Kernel.Platform.wrapTask -unwrapTask: Platform.Task e o -> (RawScheduler.Task (Result e o)) +unwrapTask : Platform.Task e o -> RawScheduler.Task (Result e o) unwrapTask = - Elm.Kernel.Basics.unwrapTypeWrapper + Elm.Kernel.Basics.unwrapTypeWrapper -wrapProcessId: ProcessId Never -> Platform.ProcessId +wrapProcessId : ProcessId Never -> Platform.ProcessId wrapProcessId = - Elm.Kernel.Platform.wrapProcessId + Elm.Kernel.Platform.wrapProcessId -unwrapProcessId: Platform.ProcessId -> ProcessId Never +unwrapProcessId : Platform.ProcessId -> ProcessId Never unwrapProcessId = - Elm.Kernel.Basics.unwrapTypeWrapper + Elm.Kernel.Basics.unwrapTypeWrapper diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index b3686cb0..eaeea2a4 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -1,14 +1,12 @@ module Platform.Sub exposing - ( Sub - , none - , batch - , map - ) + ( Sub, none, batch + , map + ) {-| > **Note:** Elm has **managed effects**, meaning that things like HTTP -> requests or writing to disk are all treated as *data* in Elm. When this +> requests or writing to disk are all treated as _data_ in Elm. When this > data is given to the Elm runtime system, it can do some “query optimization” > before actually performing the effect. Perhaps unexpectedly, this managed > effects idea is the heart of why Elm is so nice for testing, reuse, @@ -16,19 +14,25 @@ module Platform.Sub exposing > > Elm has two kinds of managed effects: commands and subscriptions. + # Subscriptions + @docs Sub, none, batch + # Fancy Stuff + @docs map + -} -import Elm.Kernel.Basics import Basics exposing (..) +import Elm.Kernel.Basics import List import Platform.Bag as Bag + -- SUBSCRIPTIONS @@ -36,9 +40,9 @@ import Platform.Bag as Bag interesting happens over there!” So if you want to listen for messages on a web socket, you would tell Elm to create a subscription. If you want to get clock ticks, you would tell Elm to subscribe to that. The cool thing here is that -this means *Elm* manages all the details of subscriptions instead of *you*. -So if a web socket goes down, *you* do not need to manually reconnect with an -exponential backoff strategy, *Elm* does this all for you behind the scenes! +this means _Elm_ manages all the details of subscriptions instead of _you_. +So if a web socket goes down, _you_ do not need to manually reconnect with an +exponential backoff strategy, _Elm_ does this all for you behind the scenes! Every `Sub` specifies (1) which effects you need access to and (2) the type of messages that will come back into your application. @@ -47,17 +51,17 @@ messages that will come back into your application. ever, subscriptions will make more sense as you work through [the Elm Architecture Tutorial](https://guide.elm-lang.org/architecture/) and see how they fit into a real application! + -} type Sub msg - = Data (Bag.EffectBag msg) - + = Data (Bag.EffectBag msg) {-| Tell the runtime that there are no subscriptions. -} none : Sub msg none = - batch [] + batch [] {-| When you need to subscribe to multiple things, you can create a `batch` of @@ -65,12 +69,14 @@ subscriptions. **Note:** `Sub.none` and `Sub.batch [ Sub.none, Sub.none ]` and `Sub.batch []` all do the same thing. + -} batch : List (Sub msg) -> Sub msg batch = - List.map (\(Data sub) -> sub) - >> List.concat - >> Data + List.map (\(Data sub) -> sub) + >> List.concat + >> Data + -- FANCY STUFF @@ -80,19 +86,22 @@ batch = Very similar to [`Html.map`](/packages/elm/html/latest/Html#map). This is very rarely useful in well-structured Elm code, so definitely read the -section on [structure][] in the guide before reaching for this! +section on [structure] in the guide before reaching for this! [structure]: https://guide.elm-lang.org/webapps/structure.html + -} map : (a -> msg) -> Sub a -> Sub msg map fn (Data data) = - data - |> List.map - (\{home, value} -> - { home = home - , value = (getSubMapper home) fn value} - ) - |> Data + data + |> List.map + (\{ home, value } -> + { home = home + , value = getSubMapper home fn value + } + ) + |> Data + -- Kernel function redefinitons -- @@ -100,5 +109,4 @@ map fn (Data data) = getSubMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg getSubMapper home = - Elm.Kernel.Platform.getSubMapper home - + Elm.Kernel.Platform.getSubMapper home diff --git a/src/Process.elm b/src/Process.elm index e6014f77..7deaaf1f 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -1,15 +1,13 @@ -module Process exposing - ( Id - , spawn - , sleep - , kill - ) +module Process exposing (Id, spawn, sleep, kill) {-| + # Processes + @docs Id, spawn, sleep, kill + ## Future Plans Right now, this library is pretty sparse. For example, there is no public API @@ -42,13 +40,14 @@ I ask that people bullish on compiling to node.js keep this in mind. I think we can do better than the hopelessly bad concurrency model of node.js, and I hope the Elm community will be supportive of being more ambitious, even if it takes longer. That’s kind of what Elm is all about. + -} import Basics exposing (..) +import Debug import Platform import Platform.Scheduler as Scheduler import Task exposing (Task) -import Debug {-| A light-weight process that runs concurrently. You can use `spawn` to @@ -56,15 +55,16 @@ get a bunch of different tasks running in different processes. The Elm runtime will interleave their progress. So if a task is taking too long, we will pause it at an `andThen` and switch over to other stuff. -**Note:** We make a distinction between *concurrency* which means interleaving -different sequences and *parallelism* which means running different +**Note:** We make a distinction between _concurrency_ which means interleaving +different sequences and _parallelism_ which means running different sequences at the exact same time. For example, a [time-sharing system](https://en.wikipedia.org/wiki/Time-sharing) is definitely concurrent, but not necessarily parallel. So even though JS runs within a single OS-level thread, Elm can still run things concurrently. + -} type alias Id = - Platform.ProcessId + Platform.ProcessId {-| Run a task in its own light-weight process. In the following example, @@ -73,15 +73,16 @@ or is just taking a long time, we can hop over to `task2` and do some work there. spawn task1 - |> Task.andThen (\_ -> spawn task2) + |> Task.andThen (\_ -> spawn task2) **Note:** This creates a relatively restricted kind of `Process` because it cannot receive any messages. More flexibility for user-defined processes will come in a later release! + -} spawn : Task x a -> Task y Id spawn = - Scheduler.spawn + Scheduler.spawn {-| Block progress on the current process for the given number of milliseconds. @@ -89,10 +90,11 @@ The JavaScript equivalent of this is [`setTimeout`][setTimeout] which lets you delay work until later. [setTimeout]: https://developer.mozilla.org/en-US/docs/Web/API/WindowTimers/setTimeout + -} sleep : Float -> Task x () sleep = - Scheduler.sleep + Scheduler.sleep {-| Sometimes you `spawn` a process, but later decide it would be a waste to @@ -102,4 +104,4 @@ flight, it will also abort the request. -} kill : Id -> Task x () kill = - Scheduler.kill + Scheduler.kill diff --git a/src/Result.elm b/src/Result.elm index df944b42..e2a6e925 100644 --- a/src/Result.elm +++ b/src/Result.elm @@ -1,29 +1,37 @@ module Result exposing - ( Result(..) - , withDefault - , map, map2, map3, map4, map5 - , andThen - , toMaybe, fromMaybe, mapError - ) + ( Result(..) + , map, map2, map3, map4, map5 + , andThen + , withDefault, toMaybe, fromMaybe, mapError + ) {-| A `Result` is the result of a computation that may fail. This is a great way to manage errors in Elm. + # Type and Constructors + @docs Result + # Mapping + @docs map, map2, map3, map4, map5 + # Chaining + @docs andThen + # Handling Errors + @docs withDefault, toMaybe, fromMaybe, mapError + -} -import Basics exposing ( Bool(..) ) -import Maybe exposing ( Maybe(..) ) +import Basics exposing (Bool(..)) +import Maybe exposing (Maybe(..)) {-| A `Result` is either `Ok` meaning the computation succeeded, or it is an @@ -37,137 +45,145 @@ type Result error value {-| If the result is `Ok` return the value, but if the result is an `Err` then return a given default value. The following examples try to parse integers. - Result.withDefault 0 (Ok 123) == 123 + Result.withDefault 0 (Ok 123) == 123 + Result.withDefault 0 (Err "no") == 0 + -} withDefault : a -> Result x a -> a withDefault def result = - case result of - Ok a -> - a + case result of + Ok a -> + a - Err _ -> - def + Err _ -> + def {-| Apply a function to a result. If the result is `Ok`, it will be converted. If the result is an `Err`, the same error value will propagate through. - map sqrt (Ok 4.0) == Ok 2.0 + map sqrt (Ok 4.0) == Ok 2.0 + map sqrt (Err "bad input") == Err "bad input" + -} map : (a -> value) -> Result x a -> Result x value map func ra = - case ra of - Ok a -> - Ok (func a) + case ra of + Ok a -> + Ok (func a) - Err e -> - Err e + Err e -> + Err e {-| Apply a function if both results are `Ok`. If not, the first `Err` will propagate through. - map2 max (Ok 42) (Ok 13) == Ok 42 - map2 max (Err "x") (Ok 13) == Err "x" - map2 max (Ok 42) (Err "y") == Err "y" + map2 max (Ok 42) (Ok 13) == Ok 42 + + map2 max (Err "x") (Ok 13) == Err "x" + + map2 max (Ok 42) (Err "y") == Err "y" + map2 max (Err "x") (Err "y") == Err "x" This can be useful if you have two computations that may fail, and you want to put them together quickly. + -} map2 : (a -> b -> value) -> Result x a -> Result x b -> Result x value map2 func ra rb = - case ra of - Err x -> - Err x - - Ok a -> - case rb of + case ra of Err x -> - Err x + Err x + + Ok a -> + case rb of + Err x -> + Err x - Ok b -> - Ok (func a b) + Ok b -> + Ok (func a b) -{-|-} +{-| -} map3 : (a -> b -> c -> value) -> Result x a -> Result x b -> Result x c -> Result x value map3 func ra rb rc = - case ra of - Err x -> - Err x - - Ok a -> - case rb of + case ra of Err x -> - Err x + Err x + + Ok a -> + case rb of + Err x -> + Err x - Ok b -> - case rc of - Err x -> - Err x + Ok b -> + case rc of + Err x -> + Err x - Ok c -> - Ok (func a b c) + Ok c -> + Ok (func a b c) -{-|-} +{-| -} map4 : (a -> b -> c -> d -> value) -> Result x a -> Result x b -> Result x c -> Result x d -> Result x value map4 func ra rb rc rd = - case ra of - Err x -> - Err x - - Ok a -> - case rb of + case ra of Err x -> - Err x - - Ok b -> - case rc of - Err x -> - Err x + Err x - Ok c -> - case rd of + Ok a -> + case rb of Err x -> - Err x + Err x + + Ok b -> + case rc of + Err x -> + Err x - Ok d -> - Ok (func a b c d) + Ok c -> + case rd of + Err x -> + Err x + Ok d -> + Ok (func a b c d) -{-|-} + +{-| -} map5 : (a -> b -> c -> d -> e -> value) -> Result x a -> Result x b -> Result x c -> Result x d -> Result x e -> Result x value map5 func ra rb rc rd re = - case ra of - Err x -> - Err x - - Ok a -> - case rb of + case ra of Err x -> - Err x - - Ok b -> - case rc of - Err x -> - Err x + Err x - Ok c -> - case rd of + Ok a -> + case rb of Err x -> - Err x + Err x + + Ok b -> + case rc of + Err x -> + Err x + + Ok c -> + case rd of + Err x -> + Err x - Ok d -> - case re of - Err x -> - Err x + Ok d -> + case re of + Err x -> + Err x - Ok e -> - Ok (func a b c d e) + Ok e -> + Ok (func a b c d e) {-| Chain together a sequence of computations that may fail. It is helpful @@ -176,23 +192,29 @@ to see its definition: andThen : (a -> Result e b) -> Result e a -> Result e b andThen callback result = case result of - Ok value -> callback value - Err msg -> Err msg + Ok value -> + callback value + + Err msg -> + Err msg This means we only continue with the callback if things are going well. For example, say you need to use (`toInt : String -> Result String Int`) to parse a month and make sure it is between 1 and 12: + toValidMonth : Int -> Result String Int toValidMonth month = - if month >= 1 && month <= 12 - then Ok month - else Err "months must be between 1 and 12" + if month >= 1 && month <= 12 then + Ok month + + else + Err "months must be between 1 and 12" toMonth : String -> Result String Int toMonth rawString = toInt rawString - |> andThen toValidMonth + |> andThen toValidMonth -- toMonth "4" == Ok 4 -- toMonth "9" == Ok 9 @@ -203,15 +225,16 @@ This allows us to come out of a chain of operations with quite a specific error message. It is often best to create a custom type that explicitly represents the exact ways your computation may fail. This way it is easy to handle in your code. + -} andThen : (a -> Result x b) -> Result x a -> Result x b andThen callback result = case result of - Ok value -> - callback value + Ok value -> + callback value - Err msg -> - Err msg + Err msg -> + Err msg {-| Transform an `Err` value. For example, say the errors we get have too much @@ -227,15 +250,16 @@ information: mapError .message (parseInt "123") == Ok 123 mapError .message (parseInt "abc") == Err "char 'a' is not a number" + -} mapError : (x -> y) -> Result x a -> Result y a mapError f result = case result of - Ok v -> - Ok v + Ok v -> + Ok v - Err e -> - Err (f e) + Err e -> + Err (f e) {-| Convert to a simpler `Maybe` if the actual error message is not needed or @@ -246,12 +270,16 @@ you need to interact with some code that primarily uses maybes. maybeParseInt : String -> Maybe Int maybeParseInt string = toMaybe (parseInt string) + -} toMaybe : Result x a -> Maybe a toMaybe result = case result of - Ok v -> Just v - Err _ -> Nothing + Ok v -> + Just v + + Err _ -> + Nothing {-| Convert from a simple `Maybe` to interact with some code that primarily @@ -262,12 +290,16 @@ uses `Results`. resultParseInt : String -> Result String Int resultParseInt string = fromMaybe ("error parsing string: " ++ toString string) (parseInt string) + -} fromMaybe : x -> Maybe a -> Result x a fromMaybe err maybe = case maybe of - Just v -> Ok v - Nothing -> Err err + Just v -> + Ok v + + Nothing -> + Err err @@ -278,9 +310,9 @@ fromMaybe err maybe = isOk : Result x a -> Bool isOk result = - case result of - Ok _ -> - True + case result of + Ok _ -> + True - Err _ -> - False + Err _ -> + False diff --git a/src/Set.elm b/src/Set.elm index 33256e64..f74e7476 100644 --- a/src/Set.elm +++ b/src/Set.elm @@ -1,34 +1,46 @@ module Set exposing - ( Set - , empty, singleton, insert, remove - , isEmpty, member, size - , union, intersect, diff - , toList, fromList - , map, foldl, foldr, filter, partition - ) + ( Set + , empty, singleton, insert, remove + , isEmpty, member, size + , union, intersect, diff + , toList, fromList + , map, foldl, foldr, filter, partition + ) {-| A set of unique values. The values can be any comparable type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists of comparable types. -Insert, remove, and query operations all take *O(log n)* time. +Insert, remove, and query operations all take _O(log n)_ time. + # Sets + @docs Set + # Build + @docs empty, singleton, insert, remove + # Query + @docs isEmpty, member, size + # Combine + @docs union, intersect, diff + # Lists + @docs toList, fromList + # Transform + @docs map, foldl, foldr, filter, partition -} @@ -42,71 +54,71 @@ import Maybe exposing (Maybe(..)) {-| Represents a set of unique values. So `(Set Int)` is a set of integers and `(Set String)` is a set of strings. -} -type Set t = - Set_elm_builtin (Dict.Dict t ()) +type Set t + = Set_elm_builtin (Dict.Dict t ()) {-| Create an empty set. -} empty : Set a empty = - Set_elm_builtin Dict.empty + Set_elm_builtin Dict.empty {-| Create a set with one value. -} singleton : comparable -> Set comparable singleton key = - Set_elm_builtin (Dict.singleton key ()) + Set_elm_builtin (Dict.singleton key ()) {-| Insert a value into a set. -} insert : comparable -> Set comparable -> Set comparable insert key (Set_elm_builtin dict) = - Set_elm_builtin (Dict.insert key () dict) + Set_elm_builtin (Dict.insert key () dict) {-| Remove a value from a set. If the value is not found, no changes are made. -} remove : comparable -> Set comparable -> Set comparable remove key (Set_elm_builtin dict) = - Set_elm_builtin (Dict.remove key dict) + Set_elm_builtin (Dict.remove key dict) {-| Determine if a set is empty. -} isEmpty : Set a -> Bool isEmpty (Set_elm_builtin dict) = - Dict.isEmpty dict + Dict.isEmpty dict {-| Determine if a value is in a set. -} member : comparable -> Set comparable -> Bool member key (Set_elm_builtin dict) = - Dict.member key dict + Dict.member key dict {-| Determine the number of elements in a set. -} size : Set a -> Int size (Set_elm_builtin dict) = - Dict.size dict + Dict.size dict {-| Get the union of two sets. Keep all values. -} union : Set comparable -> Set comparable -> Set comparable union (Set_elm_builtin dict1) (Set_elm_builtin dict2) = - Set_elm_builtin (Dict.union dict1 dict2) + Set_elm_builtin (Dict.union dict1 dict2) {-| Get the intersection of two sets. Keeps values that appear in both sets. -} intersect : Set comparable -> Set comparable -> Set comparable intersect (Set_elm_builtin dict1) (Set_elm_builtin dict2) = - Set_elm_builtin (Dict.intersect dict1 dict2) + Set_elm_builtin (Dict.intersect dict1 dict2) {-| Get the difference between the first set and the second. Keeps values @@ -114,42 +126,42 @@ that do not appear in the second set. -} diff : Set comparable -> Set comparable -> Set comparable diff (Set_elm_builtin dict1) (Set_elm_builtin dict2) = - Set_elm_builtin (Dict.diff dict1 dict2) + Set_elm_builtin (Dict.diff dict1 dict2) {-| Convert a set into a list, sorted from lowest to highest. -} toList : Set a -> List a toList (Set_elm_builtin dict) = - Dict.keys dict + Dict.keys dict {-| Convert a list into a set, removing any duplicates. -} fromList : List comparable -> Set comparable fromList list = - List.foldl insert empty list + List.foldl insert empty list {-| Fold over the values in a set, in order from lowest to highest. -} foldl : (a -> b -> b) -> b -> Set a -> b foldl func initialState (Set_elm_builtin dict) = - Dict.foldl (\key _ state -> func key state) initialState dict + Dict.foldl (\key _ state -> func key state) initialState dict {-| Fold over the values in a set, in order from highest to lowest. -} foldr : (a -> b -> b) -> b -> Set a -> b foldr func initialState (Set_elm_builtin dict) = - Dict.foldr (\key _ state -> func key state) initialState dict + Dict.foldr (\key _ state -> func key state) initialState dict {-| Map a function onto a set, creating a new set with no duplicates. -} map : (comparable -> comparable2) -> Set comparable -> Set comparable2 map func set = - fromList (foldl (\x xs -> func x :: xs) [] set) + fromList (foldl (\x xs -> func x :: xs) [] set) {-| Only keep elements that pass the given test. @@ -158,26 +170,27 @@ map func set = numbers : Set Int numbers = - Set.fromList [-2,-1,0,1,2] + Set.fromList [ -2, -1, 0, 1, 2 ] positives : Set Int positives = - Set.filter (\x -> x > 0) numbers + Set.filter (\x -> x > 0) numbers -- positives == Set.fromList [1,2] + -} filter : (comparable -> Bool) -> Set comparable -> Set comparable filter isGood (Set_elm_builtin dict) = - Set_elm_builtin (Dict.filter (\key _ -> isGood key) dict) + Set_elm_builtin (Dict.filter (\key _ -> isGood key) dict) {-| Create two new sets. The first contains all the elements that passed the given test, and the second contains all the elements that did not. -} -partition : (comparable -> Bool) -> Set comparable -> (Set comparable, Set comparable) +partition : (comparable -> Bool) -> Set comparable -> ( Set comparable, Set comparable ) partition isGood (Set_elm_builtin dict) = - let - (dict1, dict2) = - Dict.partition (\key _ -> isGood key) dict - in - (Set_elm_builtin dict1, Set_elm_builtin dict2) + let + ( dict1, dict2 ) = + Dict.partition (\key _ -> isGood key) dict + in + ( Set_elm_builtin dict1, Set_elm_builtin dict2 ) diff --git a/src/String.elm b/src/String.elm index 0e60bdd6..f8ff7e0f 100644 --- a/src/String.elm +++ b/src/String.elm @@ -1,51 +1,71 @@ module String exposing - ( String - , isEmpty, length, reverse, repeat, replace - , append, concat, split, join, words, lines - , slice, left, right, dropLeft, dropRight - , contains, startsWith, endsWith, indexes, indices - , toInt, fromInt - , toFloat, fromFloat - , fromChar, cons, uncons - , toList, fromList - , toUpper, toLower, pad, padLeft, padRight, trim, trimLeft, trimRight - , map, filter, foldl, foldr, any, all - ) + ( String, isEmpty, length, reverse, repeat, replace + , append, concat, split, join, words, lines + , slice, left, right, dropLeft, dropRight + , contains, startsWith, endsWith, indexes, indices + , toInt, fromInt + , toFloat, fromFloat + , fromChar, cons, uncons + , toList, fromList + , toUpper, toLower, pad, padLeft, padRight, trim, trimLeft, trimRight + , map, filter, foldl, foldr, any, all + ) {-| A built-in representation for efficient string manipulation. String literals -are enclosed in `"double quotes"`. Strings are *not* lists of characters. +are enclosed in `"double quotes"`. Strings are _not_ lists of characters. + # Strings + @docs String, isEmpty, length, reverse, repeat, replace + # Building and Splitting + @docs append, concat, split, join, words, lines + # Get Substrings + @docs slice, left, right, dropLeft, dropRight + # Check for Substrings + @docs contains, startsWith, endsWith, indexes, indices + # Int Conversions + @docs toInt, fromInt + # Float Conversions + @docs toFloat, fromFloat + # Char Conversions + @docs fromChar, cons, uncons + # List Conversions + @docs toList, fromList + # Formatting + Cosmetic operations such as padding with extra characters or trimming whitespace. @docs toUpper, toLower, pad, padLeft, padRight, trim, trimLeft, trimRight + # Higher-Order Functions + @docs map, filter, foldl, foldr, any, all + -} import Basics exposing (..) @@ -65,12 +85,15 @@ import Result exposing (Result) {-| A `String` is a chunk of text: "Hello!" + "How are you?" + "🙈🙉🙊" -- strings with escape characters "this\n\t\"that\"" - "\u{1F648}\u{1F649}\u{1F64A}" -- "🙈🙉🙊" + + "🙈🙉🙊" -- "🙈🙉🙊" -- multiline strings """Triple double quotes let you @@ -89,72 +112,86 @@ characters with different widths. **Note:** JavaScript lets you use double quotes and single quotes interchangably. This is not true in Elm. You must use double quotes for a `String`, and you must use single quotes for a [`Char`](Char#Char). + -} -type String = String -- NOTE: The compiler provides the real implementation. +type String + = String -- NOTE: The compiler provides the real implementation. {-| Determine if a string is empty. isEmpty "" == True + isEmpty "the world" == False + -} isEmpty : String -> Bool isEmpty string = - string == "" + string == "" {-| Get the length of a string. length "innumerable" == 11 + length "" == 0 -} length : String -> Int length = - Elm.Kernel.String.length + Elm.Kernel.String.length {-| Reverse a string. reverse "stressed" == "desserts" + -} reverse : String -> String reverse = - Elm.Kernel.String.reverse + Elm.Kernel.String.reverse -{-| Repeat a string *n* times. +{-| Repeat a string _n_ times. repeat 3 "ha" == "hahaha" + -} repeat : Int -> String -> String repeat n chunk = - repeatHelp n chunk "" + repeatHelp n chunk "" repeatHelp : Int -> String -> String -> String repeatHelp n chunk result = - if n <= 0 then - result - else - repeatHelp (Bitwise.shiftRightBy 1 n) (chunk ++ chunk) <| - if Bitwise.and n 1 == 0 then result else result ++ chunk + if n <= 0 then + result + + else + repeatHelp (Bitwise.shiftRightBy 1 n) (chunk ++ chunk) <| + if Bitwise.and n 1 == 0 then + result + + else + result ++ chunk {-| Replace all occurrences of some substring. replace "." "-" "Json.Decode.succeed" == "Json-Decode-succeed" - replace "," "/" "a,b,c,d,e" == "a/b/c/d/e" + + replace "," "/" "a,b,c,d,e" == "a/b/c/d/e" **Note:** If you need more advanced replacements, check out the [`elm/parser`][parser] or [`elm/regex`][regex] package. [parser]: /packages/elm/parser/latest [regex]: /packages/elm/regex/latest + -} replace : String -> String -> String -> String replace before after string = - join after (split before string) + join after (split before string) @@ -165,59 +202,67 @@ replace before after string = to do this. append "butter" "fly" == "butterfly" + -} append : String -> String -> String append = - Elm.Kernel.String.append + Elm.Kernel.String.append {-| Concatenate many strings into one. - concat ["never","the","less"] == "nevertheless" + concat [ "never", "the", "less" ] == "nevertheless" + -} concat : List String -> String concat strings = - join "" strings + join "" strings {-| Split a string using a given separator. - split "," "cat,dog,cow" == ["cat","dog","cow"] - split "/" "home/evan/Desktop/" == ["home","evan","Desktop", ""] + split "," "cat,dog,cow" == [ "cat", "dog", "cow" ] + + split "/" "home/evan/Desktop/" == [ "home", "evan", "Desktop", "" ] -} split : String -> String -> List String split sep string = - Elm.Kernel.List.fromArray (Elm.Kernel.String.split sep string) + Elm.Kernel.List.fromArray (Elm.Kernel.String.split sep string) {-| Put many strings together with a given separator. - join "a" ["H","w","ii","n"] == "Hawaiian" - join " " ["cat","dog","cow"] == "cat dog cow" - join "/" ["home","evan","Desktop"] == "home/evan/Desktop" + join "a" [ "H", "w", "ii", "n" ] == "Hawaiian" + + join " " [ "cat", "dog", "cow" ] == "cat dog cow" + + join "/" [ "home", "evan", "Desktop" ] == "home/evan/Desktop" + -} join : String -> List String -> String join sep chunks = - Elm.Kernel.String.join sep (Elm.Kernel.List.toArray chunks) + Elm.Kernel.String.join sep (Elm.Kernel.List.toArray chunks) {-| Break a string into words, splitting on chunks of whitespace. - words "How are \t you? \n Good?" == ["How","are","you?","Good?"] + words "How are \t you? \n Good?" == [ "How", "are", "you?", "Good?" ] + -} words : String -> List String words = - Elm.Kernel.String.words + Elm.Kernel.String.words {-| Break a string into lines, splitting on newlines. - lines "How are you?\nGood?" == ["How are you?", "Good?"] + lines "How are you?\nGood?" == [ "How are you?", "Good?" ] + -} lines : String -> List String lines = - Elm.Kernel.String.lines + Elm.Kernel.String.lines @@ -225,64 +270,76 @@ lines = {-| Take a substring given a start and end index. Negative indexes -are taken starting from the *end* of the list. +are taken starting from the _end_ of the list. + + slice 7 9 "snakes on a plane!" == "on" + + slice 0 6 "snakes on a plane!" == "snakes" + + slice 0 -7 "snakes on a plane!" == "snakes on a" - slice 7 9 "snakes on a plane!" == "on" - slice 0 6 "snakes on a plane!" == "snakes" - slice 0 -7 "snakes on a plane!" == "snakes on a" slice -6 -1 "snakes on a plane!" == "plane" + -} slice : Int -> Int -> String -> String slice = - Elm.Kernel.String.slice + Elm.Kernel.String.slice -{-| Take *n* characters from the left side of a string. +{-| Take _n_ characters from the left side of a string. left 2 "Mulder" == "Mu" + -} left : Int -> String -> String left n string = - if n < 1 then - "" - else - slice 0 n string + if n < 1 then + "" + + else + slice 0 n string -{-| Take *n* characters from the right side of a string. +{-| Take _n_ characters from the right side of a string. right 2 "Scully" == "ly" + -} right : Int -> String -> String right n string = - if n < 1 then - "" - else - slice -n (length string) string + if n < 1 then + "" + else + slice -n (length string) string -{-| Drop *n* characters from the left side of a string. + +{-| Drop _n_ characters from the left side of a string. dropLeft 2 "The Lone Gunmen" == "e Lone Gunmen" + -} dropLeft : Int -> String -> String dropLeft n string = - if n < 1 then - string - else - slice n (length string) string + if n < 1 then + string + else + slice n (length string) string -{-| Drop *n* characters from the right side of a string. + +{-| Drop _n_ characters from the right side of a string. dropRight 2 "Cigarette Smoking Man" == "Cigarette Smoking M" + -} dropRight : Int -> String -> String dropRight n string = - if n < 1 then - string - else - slice 0 -n string + if n < 1 then + string + + else + slice 0 -n string @@ -292,50 +349,60 @@ dropRight n string = {-| See if the second string contains the first one. contains "the" "theory" == True + contains "hat" "theory" == False + contains "THE" "theory" == False -} contains : String -> String -> Bool contains = - Elm.Kernel.String.contains + Elm.Kernel.String.contains {-| See if the second string starts with the first one. startsWith "the" "theory" == True + startsWith "ory" "theory" == False + -} startsWith : String -> String -> Bool startsWith = - Elm.Kernel.String.startsWith + Elm.Kernel.String.startsWith {-| See if the second string ends with the first one. endsWith "the" "theory" == False + endsWith "ory" "theory" == True + -} endsWith : String -> String -> Bool endsWith = - Elm.Kernel.String.endsWith + Elm.Kernel.String.endsWith {-| Get all of the indexes for a substring in another string. - indexes "i" "Mississippi" == [1,4,7,10] - indexes "ss" "Mississippi" == [2,5] + indexes "i" "Mississippi" == [ 1, 4, 7, 10 ] + + indexes "ss" "Mississippi" == [ 2, 5 ] + indexes "needle" "haystack" == [] + -} indexes : String -> String -> List Int indexes = - Elm.Kernel.String.indexes + Elm.Kernel.String.indexes -{-| Alias for `indexes`. -} +{-| Alias for `indexes`. +-} indices : String -> String -> List Int indices = - Elm.Kernel.String.indexes + Elm.Kernel.String.indexes @@ -346,83 +413,97 @@ indices = and VIRTUAL YELLING. toUpper "skinner" == "SKINNER" + -} toUpper : String -> String toUpper = - Elm.Kernel.String.toUpper + Elm.Kernel.String.toUpper {-| Convert a string to all lower case. Useful for case-insensitive comparisons. toLower "X-FILES" == "x-files" + -} toLower : String -> String toLower = - Elm.Kernel.String.toLower + Elm.Kernel.String.toLower {-| Pad a string on both sides until it has a given length. - pad 5 ' ' "1" == " 1 " - pad 5 ' ' "11" == " 11 " + pad 5 ' ' "1" == " 1 " + + pad 5 ' ' "11" == " 11 " + pad 5 ' ' "121" == " 121 " + -} pad : Int -> Char -> String -> String pad n char string = - let - half = - Basics.toFloat (n - length string) / 2 - in + let + half = + Basics.toFloat (n - length string) / 2 + in repeat (ceiling half) (fromChar char) ++ string ++ repeat (floor half) (fromChar char) {-| Pad a string on the left until it has a given length. - padLeft 5 '.' "1" == "....1" - padLeft 5 '.' "11" == "...11" + padLeft 5 '.' "1" == "....1" + + padLeft 5 '.' "11" == "...11" + padLeft 5 '.' "121" == "..121" + -} padLeft : Int -> Char -> String -> String padLeft n char string = - repeat (n - length string) (fromChar char) ++ string + repeat (n - length string) (fromChar char) ++ string {-| Pad a string on the right until it has a given length. - padRight 5 '.' "1" == "1...." - padRight 5 '.' "11" == "11..." + padRight 5 '.' "1" == "1...." + + padRight 5 '.' "11" == "11..." + padRight 5 '.' "121" == "121.." + -} padRight : Int -> Char -> String -> String padRight n char string = - string ++ repeat (n - length string) (fromChar char) + string ++ repeat (n - length string) (fromChar char) {-| Get rid of whitespace on both sides of a string. trim " hats \n" == "hats" + -} trim : String -> String trim = - Elm.Kernel.String.trim + Elm.Kernel.String.trim {-| Get rid of whitespace on the left of a string. trimLeft " hats \n" == "hats \n" + -} trimLeft : String -> String trimLeft = - Elm.Kernel.String.trimLeft + Elm.Kernel.String.trimLeft {-| Get rid of whitespace on the right of a string. trimRight " hats \n" == " hats" + -} trimRight : String -> String trimRight = - Elm.Kernel.String.trimRight + Elm.Kernel.String.trimRight @@ -432,32 +513,39 @@ trimRight = {-| Try to convert a string into an int, failing on improperly formatted strings. String.toInt "123" == Just 123 + String.toInt "-42" == Just -42 + String.toInt "3.1" == Nothing + String.toInt "31a" == Nothing If you are extracting a number from some raw user input, you will typically want to use [`Maybe.withDefault`](Maybe#withDefault) to handle bad data: Maybe.withDefault 0 (String.toInt "42") == 42 + Maybe.withDefault 0 (String.toInt "ab") == 0 + -} toInt : String -> Maybe Int toInt = - Elm.Kernel.String.toInt + Elm.Kernel.String.toInt {-| Convert an `Int` to a `String`. String.fromInt 123 == "123" + String.fromInt -42 == "-42" -Check out [`Debug.toString`](Debug#toString) to convert *any* value to a string +Check out [`Debug.toString`](Debug#toString) to convert _any_ value to a string for debugging purposes. + -} fromInt : Int -> String fromInt = - Elm.Kernel.String.fromNumber + Elm.Kernel.String.fromNumber @@ -467,33 +555,41 @@ fromInt = {-| Try to convert a string into a float, failing on improperly formatted strings. String.toFloat "123" == Just 123.0 + String.toFloat "-42" == Just -42.0 + String.toFloat "3.1" == Just 3.1 + String.toFloat "31a" == Nothing If you are extracting a number from some raw user input, you will typically want to use [`Maybe.withDefault`](Maybe#withDefault) to handle bad data: Maybe.withDefault 0 (String.toFloat "42.5") == 42.5 + Maybe.withDefault 0 (String.toFloat "cats") == 0 + -} toFloat : String -> Maybe Float toFloat = - Elm.Kernel.String.toFloat + Elm.Kernel.String.toFloat {-| Convert a `Float` to a `String`. String.fromFloat 123 == "123" + String.fromFloat -42 == "-42" + String.fromFloat 3.9 == "3.9" -Check out [`Debug.toString`](Debug#toString) to convert *any* value to a string +Check out [`Debug.toString`](Debug#toString) to convert _any_ value to a string for debugging purposes. + -} fromFloat : Float -> String fromFloat = - Elm.Kernel.String.fromNumber + Elm.Kernel.String.fromNumber @@ -502,24 +598,28 @@ fromFloat = {-| Convert a string to a list of characters. - toList "abc" == ['a','b','c'] - toList "🙈🙉🙊" == ['🙈','🙉','🙊'] + toList "abc" == [ 'a', 'b', 'c' ] + + toList "🙈🙉🙊" == [ '🙈', '🙉', '🙊' ] + -} toList : String -> List Char toList string = - foldr (::) [] string + foldr (::) [] string {-| Convert a list of characters into a String. Can be useful if you want to create a string primarily by consing, perhaps for decoding something. - fromList ['a','b','c'] == "abc" - fromList ['🙈','🙉','🙊'] == "🙈🙉🙊" + fromList [ 'a', 'b', 'c' ] == "abc" + + fromList [ '🙈', '🙉', '🙊' ] == "🙈🙉🙊" + -} fromList : List Char -> String fromList = - Elm.Kernel.String.fromList + Elm.Kernel.String.fromList @@ -529,30 +629,34 @@ fromList = {-| Create a string from a given character. fromChar 'a' == "a" + -} fromChar : Char -> String fromChar char = - cons char "" + cons char "" {-| Add a character to the beginning of a string. cons 'T' "he truth is out there" == "The truth is out there" + -} cons : Char -> String -> String cons = - Elm.Kernel.String.cons + Elm.Kernel.String.cons {-| Split a non-empty string into its head and tail. This lets you pattern match on strings exactly as you would with lists. - uncons "abc" == Just ('a',"bc") - uncons "" == Nothing + uncons "abc" == Just ( 'a', "bc" ) + + uncons "" == Nothing + -} -uncons : String -> Maybe (Char, String) +uncons : String -> Maybe ( Char, String ) uncons = - Elm.Kernel.String.uncons + Elm.Kernel.String.uncons @@ -561,57 +665,76 @@ uncons = {-| Transform every character in a string - map (\c -> if c == '/' then '.' else c) "a/b/c" == "a.b.c" + map + (\c -> + if c == '/' then + '.' + + else + c + ) + "a/b/c" + == "a.b.c" + -} map : (Char -> Char) -> String -> String map = - Elm.Kernel.String.map + Elm.Kernel.String.map {-| Keep only the characters that pass the test. filter isDigit "R2-D2" == "22" + -} filter : (Char -> Bool) -> String -> String filter = - Elm.Kernel.String.filter + Elm.Kernel.String.filter {-| Reduce a string from the left. foldl cons "" "time" == "emit" + -} foldl : (Char -> b -> b) -> b -> String -> b foldl = - Elm.Kernel.String.foldl + Elm.Kernel.String.foldl {-| Reduce a string from the right. foldr cons "" "time" == "time" + -} foldr : (Char -> b -> b) -> b -> String -> b foldr = - Elm.Kernel.String.foldr + Elm.Kernel.String.foldr -{-| Determine whether *any* characters pass the test. +{-| Determine whether _any_ characters pass the test. any isDigit "90210" == True + any isDigit "R2-D2" == True + any isDigit "heart" == False + -} any : (Char -> Bool) -> String -> Bool any = - Elm.Kernel.String.any + Elm.Kernel.String.any -{-| Determine whether *all* characters pass the test. +{-| Determine whether _all_ characters pass the test. all isDigit "90210" == True + all isDigit "R2-D2" == False + all isDigit "heart" == False + -} all : (Char -> Bool) -> String -> Bool all = - Elm.Kernel.String.all + Elm.Kernel.String.all diff --git a/src/Task.elm b/src/Task.elm index 688950e6..139b07b8 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -1,31 +1,36 @@ effect module Task where { command = MyCmd } exposing - ( Task - , succeed, fail - , map, map2, map3, map4, map5 - , sequence - , andThen - , onError, mapError - , perform, attempt - ) + ( Task, perform, attempt + , andThen, succeed, fail, sequence + , map, map2, map3, map4, map5 + , onError, mapError + ) {-| Tasks make it easy to describe asynchronous operations that may fail, like HTTP requests or writing to a database. + # Tasks + @docs Task, perform, attempt + # Chains + @docs andThen, succeed, fail, sequence + # Maps + @docs map, map2, map3, map4, map5 + # Errors + @docs onError, mapError -} -import Basics exposing (Never, (|>), (<<)) +import Basics exposing ((<<), (|>), Never) import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform @@ -34,12 +39,11 @@ import Platform.Scheduler as Scheduler import Result exposing (Result(..)) - {-| Here are some common tasks: -- [`now : Task x Posix`][now] -- [`focus : String -> Task Error ()`][focus] -- [`sleep : Float -> Task x ()`][sleep] + - [`now : Task x Posix`][now] + - [`focus : String -> Task Error ()`][focus] + - [`sleep : Float -> Task x ()`][sleep] [now]: /packages/elm/time/latest/Time#now [focus]: /packages/elm/browser/latest/Browser-Dom#focus @@ -55,9 +59,10 @@ More generally a task is a _description_ of what you need to do. Like a todo list. Or like a grocery list. Or like GitHub issues. So saying "the task is to tell me the current POSIX time" does not complete the task! You need [`perform`](#perform) tasks or [`attempt`](#attempt) tasks. + -} type alias Task x a = - Platform.Task x a + Platform.Task x a @@ -67,31 +72,35 @@ type alias Task x a = {-| A task that succeeds immediately when run. It is usually used with [`andThen`](#andThen). You can use it like `map` if you want: - import Time -- elm install elm/time + import Time + + -- elm install elm/time timeInMillis : Task x Int timeInMillis = - Time.now - |> andThen (\t -> succeed (Time.posixToMillis t)) + Time.now + |> andThen (\t -> succeed (Time.posixToMillis t)) -} succeed : a -> Task x a succeed = - Scheduler.succeed + Scheduler.succeed {-| A task that fails immediately when run. Like with `succeed`, this can be used with `andThen` to check on the outcome of another task. - type Error = NotFound + type Error + = NotFound notFound : Task Error a notFound = - fail NotFound + fail NotFound + -} fail : x -> Task x a fail = - Scheduler.fail + Scheduler.fail @@ -102,75 +111,111 @@ fail = out what time it will be in one hour: import Task exposing (Task) - import Time -- elm install elm/time + import Time + + -- elm install elm/time timeInOneHour : Task x Time.Posix timeInOneHour = - Task.map addAnHour Time.now + Task.map addAnHour Time.now addAnHour : Time.Posix -> Time.Posix addAnHour time = - Time.millisToPosix (Time.posixToMillis time + 60 * 60 * 1000) + Time.millisToPosix (Time.posixToMillis time + 60 * 60 * 1000) [time]: /packages/elm/time/latest/ + -} map : (a -> b) -> Task x a -> Task x b map func taskA = - taskA - |> andThen (\a -> succeed (func a)) + taskA + |> andThen (\a -> succeed (func a)) {-| Put the results of two tasks together. For example, if we wanted to know the current month, we could use [`elm/time`][time] to ask: import Task exposing (Task) - import Time -- elm install elm/time + import Time + + -- elm install elm/time getMonth : Task x Int getMonth = - Task.map2 Time.toMonth Time.here Time.now + Task.map2 Time.toMonth Time.here Time.now **Note:** Say we were doing HTTP requests instead. `map2` does each task in order, so it would try the first request and only continue after it succeeds. If it fails, the whole thing fails! [time]: /packages/elm/time/latest/ + -} map2 : (a -> b -> result) -> Task x a -> Task x b -> Task x result map2 func taskA taskB = - taskA - |> andThen (\a -> taskB - |> andThen (\b -> succeed (func a b))) + taskA + |> andThen + (\a -> + taskB + |> andThen (\b -> succeed (func a b)) + ) -{-|-} +{-| -} map3 : (a -> b -> c -> result) -> Task x a -> Task x b -> Task x c -> Task x result map3 func taskA taskB taskC = - taskA - |> andThen (\a -> taskB - |> andThen (\b -> taskC - |> andThen (\c -> succeed (func a b c)))) - - -{-|-} + taskA + |> andThen + (\a -> + taskB + |> andThen + (\b -> + taskC + |> andThen (\c -> succeed (func a b c)) + ) + ) + + +{-| -} map4 : (a -> b -> c -> d -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x result map4 func taskA taskB taskC taskD = - taskA - |> andThen (\a -> taskB - |> andThen (\b -> taskC - |> andThen (\c -> taskD - |> andThen (\d -> succeed (func a b c d))))) - - -{-|-} + taskA + |> andThen + (\a -> + taskB + |> andThen + (\b -> + taskC + |> andThen + (\c -> + taskD + |> andThen (\d -> succeed (func a b c d)) + ) + ) + ) + + +{-| -} map5 : (a -> b -> c -> d -> e -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x e -> Task x result map5 func taskA taskB taskC taskD taskE = - taskA - |> andThen (\a -> taskB - |> andThen (\b -> taskC - |> andThen (\c -> taskD - |> andThen (\d -> taskE - |> andThen (\e -> succeed (func a b c d e)))))) + taskA + |> andThen + (\a -> + taskB + |> andThen + (\b -> + taskC + |> andThen + (\c -> + taskD + |> andThen + (\d -> + taskE + |> andThen (\e -> succeed (func a b c d e)) + ) + ) + ) + ) {-| Start with a list of tasks, and turn them into a single task that returns a @@ -182,7 +227,7 @@ sequence fails. -} sequence : List (Task x a) -> Task x (List a) sequence tasks = - List.foldr (map2 (::)) (succeed []) tasks + List.foldr (map2 (::)) (succeed []) tasks @@ -194,19 +239,22 @@ successful, you give the result to the callback resulting in another task. This task then gets run. We could use this to make a task that resolves an hour from now: - import Time -- elm install elm/time + -- elm install elm/time + import Process + import Time timeInOneHour : Task x Time.Posix timeInOneHour = - Process.sleep (60 * 60 * 1000) - |> andThen (\_ -> Time.now) + Process.sleep (60 * 60 * 1000) + |> andThen (\_ -> Time.now) First the process sleeps for an hour **and then** it tells us what time it is. + -} andThen : (a -> Task x b) -> Task x a -> Task x b andThen = - Scheduler.andThen + Scheduler.andThen @@ -223,54 +271,58 @@ callback to recover. succeed 9 |> onError (\msg -> succeed 42) -- succeed 9 + -} onError : (x -> Task y a) -> Task x a -> Task y a onError = - Scheduler.onError + Scheduler.onError {-| Transform the error value. This can be useful if you need a bunch of error types to match up. type Error - = Http Http.Error - | WebGL WebGL.Error + = Http Http.Error + | WebGL WebGL.Error getResources : Task Error Resource getResources = - sequence - [ mapError Http serverTask - , mapError WebGL textureTask - ] + sequence + [ mapError Http serverTask + , mapError WebGL textureTask + ] + -} mapError : (x -> y) -> Task x a -> Task y a mapError convert task = - task - |> onError (fail << convert) + task + |> onError (fail << convert) -- COMMANDS -type MyCmd msg = - Perform (Task Never msg) +type MyCmd msg + = Perform (Task Never msg) {-| Like I was saying in the [`Task`](#Task) documentation, just having a `Task` does not mean it is done. We must command Elm to `perform` the task: - import Time -- elm install elm/time + -- elm install elm/time + import Task + import Time type Msg - = Click - | Search String - | NewTime Time.Posix + = Click + | Search String + | NewTime Time.Posix getNewTime : Cmd Msg getNewTime = - Task.perform NewTime Time.now + Task.perform NewTime Time.now If you have worked through [`guide.elm-lang.org`][guide] (highly recommended!) you will recognize `Cmd` from the section on The Elm Architecture. So we have @@ -278,26 +330,29 @@ changed a task like "make delicious lasagna" into a command like "Hey Elm, make delicious lasagna and give it to my `update` function as a `Msg` value." [guide]: https://guide.elm-lang.org/ + -} perform : (a -> msg) -> Task Never a -> Cmd msg perform toMessage task = - command (Perform (map toMessage task)) + command (Perform (map toMessage task)) {-| This is very similar to [`perform`](#perform) except it can handle failures! So we could _attempt_ to focus on a certain DOM node like this: - import Browser.Dom -- elm install elm/browser + -- elm install elm/browser + + import Browser.Dom import Task type Msg - = Click - | Search String - | Focus (Result Browser.DomError ()) + = Click + | Search String + | Focus (Result Browser.DomError ()) focus : Cmd Msg focus = - Task.attempt Focus (Browser.Dom.focus "my-app-search-box") + Task.attempt Focus (Browser.Dom.focus "my-app-search-box") So the task is "focus on this DOM node" and we are turning it into the command "Hey Elm, attempt to focus on this DOM node and give me a `Msg` about whether @@ -307,19 +362,22 @@ you succeeded or failed." feeling for how commands fit into The Elm Architecture. [guide]: https://guide.elm-lang.org/ + -} attempt : (Result x a -> msg) -> Task x a -> Cmd msg attempt resultToMessage task = - command (Perform ( - task - |> andThen (succeed << resultToMessage << Ok) - |> onError (succeed << resultToMessage << Err) - )) + command + (Perform + (task + |> andThen (succeed << resultToMessage << Ok) + |> onError (succeed << resultToMessage << Err) + ) + ) cmdMap : (a -> b) -> MyCmd a -> MyCmd b cmdMap tagger (Perform task) = - Perform (map tagger task) + Perform (map tagger task) @@ -328,24 +386,24 @@ cmdMap tagger (Perform task) = init : Task Never () init = - succeed () + succeed () onEffects : Platform.Router msg Never -> List (MyCmd msg) -> () -> Task Never () onEffects router commands state = - map - (\_ -> ()) - (sequence (List.map (spawnCmd router) commands)) + map + (\_ -> ()) + (sequence (List.map (spawnCmd router) commands)) onSelfMsg : Platform.Router msg Never -> Never -> () -> Task Never () onSelfMsg _ _ _ = - succeed () + succeed () spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x Platform.ProcessId spawnCmd router (Perform task) = - Scheduler.spawn ( - task - |> andThen (Platform.sendToApp router) - ) + Scheduler.spawn + (task + |> andThen (Platform.sendToApp router) + ) diff --git a/src/Tuple.elm b/src/Tuple.elm index a92436a7..d6980d4c 100644 --- a/src/Tuple.elm +++ b/src/Tuple.elm @@ -1,18 +1,18 @@ module Tuple exposing - ( pair - , first, second - , mapFirst, mapSecond, mapBoth - ) + ( pair + , first, second + , mapFirst, mapSecond, mapBoth + ) {-| Elm has built-in syntax for tuples, so you can define 2D points like this: - origin : (Float, Float) + origin : ( Float, Float ) origin = - (0, 0) + ( 0, 0 ) - position : (Float, Float) + position : ( Float, Float ) position = - (3, 4) + ( 3, 4 ) This module is a bunch of helpers for working with 2-tuples. @@ -27,33 +27,37 @@ info on this. (Picking appropriate data structures is super important in Elm!) [ut]: https://robots.thoughtbot.com/modeling-with-union-types + # Create + @docs pair + # Access + @docs first, second + # Map + @docs mapFirst, mapSecond, mapBoth -} - - -- CREATE {-| Create a 2-tuple. -- pair 3 4 == (3, 4) - - zip : List a -> List b -> List (a, b) + zip : List a -> List b -> List ( a, b ) zip xs ys = - List.map2 Tuple.pair xs ys + List.map2 Tuple.pair xs ys + -} -pair : a -> b -> (a, b) +pair : a -> b -> ( a, b ) pair a b = - (a, b) + ( a, b ) @@ -62,22 +66,26 @@ pair a b = {-| Extract the first value from a tuple. - first (3, 4) == 3 - first ("john", "doe") == "john" + first ( 3, 4 ) == 3 + + first ( "john", "doe" ) == "john" + -} -first : (a, b) -> a -first (x,_) = - x +first : ( a, b ) -> a +first ( x, _ ) = + x {-| Extract the second value from a tuple. - second (3, 4) == 4 - second ("john", "doe") == "doe" + second ( 3, 4 ) == 4 + + second ( "john", "doe" ) == "doe" + -} -second : (a, b) -> b -second (_,y) = - y +second : ( a, b ) -> b +second ( _, y ) = + y @@ -90,20 +98,23 @@ second (_,y) = mapFirst String.reverse ("stressed", 16) == ("desserts", 16) mapFirst String.length ("stressed", 16) == (8, 16) + -} -mapFirst : (a -> x) -> (a, b) -> (x, b) -mapFirst func (x,y) = - (func x, y) +mapFirst : (a -> x) -> ( a, b ) -> ( x, b ) +mapFirst func ( x, y ) = + ( func x, y ) {-| Transform the second value in a tuple. - mapSecond sqrt ("stressed", 16) == ("stressed", 4) - mapSecond negate ("stressed", 16) == ("stressed", -16) + mapSecond sqrt ( "stressed", 16 ) == ( "stressed", 4 ) + + mapSecond negate ( "stressed", 16 ) == ( "stressed", -16 ) + -} -mapSecond : (b -> y) -> (a, b) -> (a, y) -mapSecond func (x,y) = - (x, func y) +mapSecond : (b -> y) -> ( a, b ) -> ( a, y ) +mapSecond func ( x, y ) = + ( x, func y ) {-| Transform both parts of a tuple. @@ -112,7 +123,8 @@ mapSecond func (x,y) = mapBoth String.reverse sqrt ("stressed", 16) == ("desserts", 4) mapBoth String.length negate ("stressed", 16) == (8, -16) + -} -mapBoth : (a -> x) -> (b -> y) -> (a, b) -> (x, y) -mapBoth funcA funcB (x,y) = - ( funcA x, funcB y ) +mapBoth : (a -> x) -> (b -> y) -> ( a, b ) -> ( x, y ) +mapBoth funcA funcB ( x, y ) = + ( funcA x, funcB y ) From c8d1a96d126c85473149605fa6046e3137c2eb0a Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 21:06:54 +0000 Subject: [PATCH 058/170] explicit exports from new elm files --- src/Platform/RawScheduler.elm | 2 +- src/Platform/Scheduler.elm | 2 +- src/Task.elm | 3 +++ 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 66a12e51..06cb951e 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (..) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, kill, newProcessId, rawSend, rawSpawn, send, sleep, spawn) {-| diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 222f2e99..c6ce4a6b 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Scheduler exposing (..) +module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, send, sleep, spawn, succeed) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. diff --git a/src/Task.elm b/src/Task.elm index 139b07b8..787d4290 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -241,6 +241,7 @@ now: -- elm install elm/time + import Process import Time @@ -312,6 +313,7 @@ type MyCmd msg -- elm install elm/time + import Task import Time @@ -342,6 +344,7 @@ So we could _attempt_ to focus on a certain DOM node like this: -- elm install elm/browser + import Browser.Dom import Task From f81ce3fc28c292ebe1e50e24ea0e5d3bfb89bab9 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 21:17:16 +0000 Subject: [PATCH 059/170] explain RawScheduler --- src/Platform/RawScheduler.elm | 52 ++++++++++++----------------------- 1 file changed, 18 insertions(+), 34 deletions(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 06cb951e..ea176c9c 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,39 +1,23 @@ module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, kill, newProcessId, rawSend, rawSpawn, send, sleep, spawn) -{-| - - -## Module notes: - - - Types called `HiddenXXX` are used to bypass the elm type system. - The programmer takes **full responsibiliy** for making sure - that the types line up. - That does mean you have to second guess any and all strange - decisions I have made, hopefully things will get clearer over - time. - - - The `Binding` constructor on the `Task` type is tricky one. - - It contains a callback function (that we will call `doEffect`) - and a `killer` function. `doEffect` will be called by - `Scheduler.enqueue` and will be passed another callback. - We call this second callback `doneCallback`. - `doEffect` should do its effects (which may be impure) and then, - when it is done, call `doneCallback`.`doEffect` **must** call - `doneCallback` and it **must** pass `doneCallback` a - `Task ErrX OkX` as an argument. (I am unsure about the values of - ErrX and OkX at the moment). The return value of `doEffect` may - be either `undefined` or a function that cancels the effect. - - If the second value `killer` is not Nothing, then the runtime - will call it if the execution of the `Task` should be aborted. - - -## Differences between this and offical elm/core - - - `Process.mailbox` is a (mutable) js array in elm/core and an elm list here. - - `Process.stack` is an (immutable) js linked list in elm/core and an elm list here. - - `Elm.Kernel.Scheduler.rawSend` mutates the process before enqueuing it in elm/core. - Here we create a **new** process with the **same** (unique) id and then enqueue it. - Same applies for (non-raw) `send`. +{-| This module contains the low level logic for running tasks and processes. A +`Task` is a sequence of actions (either syncronous or asyncronous) that will be +run in order by the runtime. A process (outside this module a process is +accessed and manipulated using its unique id) is a task paired with a +"receiver". If a process is sent a message (using the `send` function) it is +added to the processes mailbox. When the process completes execution of its +current `Task` (or immediately if it has already finished execution of its +`Task`) it will envoke its receiver function with the oldest message in the +mailbox and the final state of its `Task`. The receiver function should produce +a new `Task` for the process to execute. + +Processes spawned by user elm code (using `Process.spawn`) cannot receive +messages so will execute their initial `Task` and then die. + +Only two modules should import this module directly `Platform.Scheduler` and +`Platform`. All other modules should import `Platform.Scheduler` which has a +nicer API. `Platform` cannot import `Platform.Scheduler` as +`Platfrom.Scheduler` imports `Platform` and elm does not allow import cycles. -} From ee3e84222f1ed8d96e978abd1782c24d7585c068 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 21:18:30 +0000 Subject: [PATCH 060/170] access getGuid via elm redefinition --- src/Platform/RawScheduler.elm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index ea176c9c..ea732351 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -89,7 +89,7 @@ may even fail silently in optimized compiles.) -} newProcessId : () -> ProcessId msg newProcessId () = - ProcessId { id = Elm.Kernel.Scheduler.getGuid () } + ProcessId { id = getGuid () } {-| NON PURE! @@ -261,6 +261,10 @@ stepper processId onAsyncActionDone (ProcessState process) = -- Kernel function redefinitons -- +getGuid : () -> UniqueId +getGuid = + Elm.Kernel.Scheduler.getGuid + updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state updateProcessState = Elm.Kernel.Scheduler.updateProcessState From a6ae569d418fc7ff26679e542fedce1f3240a8f5 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 21:36:42 +0000 Subject: [PATCH 061/170] correct type of incomingPort MySub msgs Also improves discipline with not using untyped Elm.Kernel.Basics.fudgeType. --- src/Basics.elm | 2 + src/Platform.elm | 106 +++++++++++++++++++++------------- src/Platform/RawScheduler.elm | 3 +- 3 files changed, 70 insertions(+), 41 deletions(-) diff --git a/src/Basics.elm b/src/Basics.elm index 5de2b46d..578d3ecc 100644 --- a/src/Basics.elm +++ b/src/Basics.elm @@ -290,6 +290,8 @@ similar to `truncate (3 / 4)`. It may sometimes be useful to pair this with the [`remainderBy`](#remainderBy) function. +TODO(harry) fix example + -} idiv : Int -> Int -> Int idiv lhs rhs = diff --git a/src/Platform.elm b/src/Platform.elm index a1371bc3..64143b7c 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -30,12 +30,6 @@ curious? Public discussions of your explorations should be framed accordingly. @docs Router, sendToApp, sendToSelf - -## Unresolve questions - - - Each app has a dict of effect managers, it also has a dict of "managers". - I have called these `OtherManagers` but what do they do and how shouuld they be named? - -} -- import Json.Decode exposing (Decoder) @@ -230,23 +224,21 @@ setupOutgoingPort outgoingPortSend = RawScheduler.Value (Ok ()) onEffects : - Router msg selfMsg - -> List (HiddenMyCmd msg) - -> List (HiddenMySub msg) + Router Never Never + -> List (HiddenMyCmd Never) + -> List (HiddenMySub Never) -> () -> Task Never () onEffects _ cmdList _ () = - let - typedCmdList : List EncodeValue - typedCmdList = - Elm.Kernel.Basics.fudgeType cmdList - in - Task (execInOrder typedCmdList) + Task (execInOrder (createValuesToSendOutOfPorts cmdList)) in instantiateEffectManager (\msg -> never msg) init onEffects onSelfMsg -setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) -> ( RawScheduler.ProcessId (ReceivedData msg Never), msg -> List (HiddenMySub msg) -> () ) +setupIncomingPort : + SendToApp msg + -> (List (HiddenMySub msg) -> ()) + -> ( RawScheduler.ProcessId (ReceivedData msg Never), EncodeValue -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -267,19 +259,13 @@ setupIncomingPort sendToApp2 updateSubs = ) ) - onSend : msg -> List (HiddenMySub msg) -> () onSend value subs = List.foldr (\sub () -> - let - typedSub : msg -> msg - typedSub = - Elm.Kernel.Basics.fudgeType sub - in - sendToApp2 (typedSub value) AsyncUpdate + sendToApp2 (sub value) AsyncUpdate ) () - subs + (createIncomingPortConverters subs) in ( instantiateEffectManager sendToApp2 init onEffects onSelfMsg , onSend @@ -309,12 +295,15 @@ dispatchEffects cmdBag subBag = _ = RawScheduler.rawSend selfProcess - (App (Elm.Kernel.Basics.fudgeType cmdList) (Elm.Kernel.Basics.fudgeType subList)) + (App (createHiddenMyCmdList cmdList) (createHiddenMySubList subList)) in () -gatherCmds : Cmd msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) +gatherCmds : + Cmd msg + -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) + -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) gatherCmds cmdBag effectsDict = List.foldr (\{ home, value } dict -> gatherHelper True home value dict) @@ -322,7 +311,10 @@ gatherCmds cmdBag effectsDict = (unwrapCmd cmdBag) -gatherSubs : Sub msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) +gatherSubs : + Sub msg + -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) + -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) gatherSubs subBag effectsDict = List.foldr (\{ home, value } dict -> gatherHelper False home value dict) @@ -330,7 +322,12 @@ gatherSubs subBag effectsDict = (unwrapSub subBag) -gatherHelper : Bool -> Bag.EffectManagerName -> Bag.LeafType msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) +gatherHelper : + Bool + -> Bag.EffectManagerName + -> Bag.LeafType msg + -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) + -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) gatherHelper isCmd home effectData effectsDict = Dict.insert (effectManagerNameToString home) @@ -338,7 +335,11 @@ gatherHelper isCmd home effectData effectsDict = effectsDict -createEffect : Bool -> Bag.LeafType msg -> Maybe ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -> ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) +createEffect : + Bool + -> Bag.LeafType msg + -> Maybe ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) + -> ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) createEffect isCmd newEffect maybeEffects = let ( cmdList, subList ) = @@ -489,20 +490,25 @@ type alias Impl flags model msg = } -type alias SetupEffects state appMsg selfMsg = - SendToApp appMsg - -> Task Never state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) - -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) - - type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg , setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) - , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), appMsg -> List (HiddenMySub appMsg) -> () ) - , setupEffects : SetupEffects HiddenState appMsg HiddenSelfMsg - , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () + , setupIncomingPort : + SendToApp appMsg + -> (List (HiddenMySub appMsg) -> ()) + -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), EncodeValue -> List (HiddenMySub appMsg) -> () ) + , setupEffects : + SendToApp appMsg + -> Task Never HiddenState + -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) + -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + , dispatchEffects : + Cmd appMsg + -> Sub appMsg + -> Bag.EffectManagerName + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> () } @@ -545,3 +551,23 @@ unwrapCmd = unwrapSub : Sub a -> Bag.EffectBag a unwrapSub = Elm.Kernel.Basics.unwrapTypeWrapper + + +createHiddenMyCmdList : List (Bag.LeafType msg) -> List (HiddenMyCmd msg) +createHiddenMyCmdList = + Elm.Kernel.Basics.fudgeType + + +createHiddenMySubList : List (Bag.LeafType msg) -> List (HiddenMySub msg) +createHiddenMySubList = + Elm.Kernel.Basics.fudgeType + + +createValuesToSendOutOfPorts : List (HiddenMyCmd Never) -> List EncodeValue +createValuesToSendOutOfPorts = + Elm.Kernel.Basics.fudgeType + + +createIncomingPortConverters : List (HiddenMySub msg) -> List (EncodeValue -> msg) +createIncomingPortConverters = + Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index ea732351..973e59da 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -263,7 +263,8 @@ stepper processId onAsyncActionDone (ProcessState process) = getGuid : () -> UniqueId getGuid = - Elm.Kernel.Scheduler.getGuid + Elm.Kernel.Scheduler.getGuid + updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state updateProcessState = From 8562f4374400286fde2f4208599f1603747ecbc8 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Dec 2019 23:20:56 +0000 Subject: [PATCH 062/170] misc code tidying I was helped by elm-analyse here --- src/Platform.elm | 92 ++++++++--------------------------- src/Platform/Cmd.elm | 2 +- src/Platform/RawScheduler.elm | 5 +- src/Platform/Scheduler.elm | 4 +- src/Platform/Sub.elm | 2 +- src/Process.elm | 3 +- src/Task.elm | 8 +-- 7 files changed, 30 insertions(+), 86 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 64143b7c..f9c246a2 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -32,32 +32,20 @@ curious? Public discussions of your explorations should be framed accordingly. -} --- import Json.Decode exposing (Decoder) --- import Json.Encode as Encode - import Basics exposing (..) -import Char exposing (Char) -import Debug import Dict exposing (Dict) import Elm.Kernel.Basics import Elm.Kernel.Platform +import Json.Decode exposing (Decoder) +import Json.Encode as Encode import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform.Bag as Bag -import Platform.Cmd as Cmd exposing (Cmd) +import Platform.Cmd exposing (Cmd) import Platform.RawScheduler as RawScheduler -import Platform.Sub as Sub exposing (Sub) +import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) -import Tuple - - -type Decoder flags - = Decoder (Decoder flags) - - -type EncodeValue - = EncodeValue EncodeValue @@ -71,15 +59,8 @@ type Program flags model msg = Program (Decoder flags -> DebugMetadata - -> RawJsObject { args : Maybe (RawJsObject flags) } - -> - RawJsObject - { ports : - RawJsObject - { outgoingPortName : OutgoingPort - , incomingPortName : IncomingPort - } - } + -> RawJsObject + -> RawJsObject ) @@ -198,7 +179,7 @@ sendToSelf (Router router) msg = -- HELPERS -- -setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) +setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = let init = @@ -207,7 +188,7 @@ setupOutgoingPort outgoingPortSend = onSelfMsg _ selfMsg () = never selfMsg - execInOrder : List EncodeValue -> RawScheduler.Task (Result Never ()) + execInOrder : List Encode.Value -> RawScheduler.Task (Result Never ()) execInOrder cmdList = case cmdList of first :: rest -> @@ -238,7 +219,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData msg Never), EncodeValue -> List (HiddenMySub msg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -414,12 +395,8 @@ type alias SendToApp msg = msg -> UpdateMetadata -> () -type alias StepperBuilder model msg = - SendToApp msg -> model -> SendToApp msg - - type alias DebugMetadata = - EncodeValue + Encode.Value {-| AsyncUpdate is default I think @@ -441,33 +418,12 @@ type ReceivedData appMsg selfMsg | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) -type OutgoingPort - = OutgoingPort - { subscribe : EncodeValue -> () - , unsubscribe : EncodeValue -> () - } - - -type IncomingPort - = IncomingPort - { send : EncodeValue -> () - } - - -type HiddenTypeA - = HiddenTypeA Never - - -type HiddenTypeB - = HiddenTypeB Never - - type HiddenMyCmd msg - = HiddenMyCmd (Bag.LeafType msg) + = HiddenMyCmd (HiddenMyCmd msg) type HiddenMySub msg - = HiddenMySub (Bag.LeafType msg) + = HiddenMySub (HiddenMySub msg) type HiddenSelfMsg @@ -478,9 +434,8 @@ type HiddenState = HiddenState HiddenState -type RawJsObject record - = JsRecord (RawJsObject record) - | JsAny +type RawJsObject + = RawJsObject RawJsObject type alias Impl flags model msg = @@ -492,11 +447,11 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (EncodeValue -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) + , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), EncodeValue -> List (HiddenMySub appMsg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState @@ -518,17 +473,10 @@ type alias InitFunctions model appMsg = initialize : Decoder flags - -> RawJsObject { args : Maybe (RawJsObject flags) } + -> RawJsObject -> Impl flags model msg -> InitFunctions model msg - -> - RawJsObject - { ports : - RawJsObject - { outgoingPortName : OutgoingPort - , incomingPortName : IncomingPort - } - } + -> RawJsObject initialize = Elm.Kernel.Platform.initialize @@ -563,11 +511,11 @@ createHiddenMySubList = Elm.Kernel.Basics.fudgeType -createValuesToSendOutOfPorts : List (HiddenMyCmd Never) -> List EncodeValue +createValuesToSendOutOfPorts : List (HiddenMyCmd Never) -> List Encode.Value createValuesToSendOutOfPorts = Elm.Kernel.Basics.fudgeType -createIncomingPortConverters : List (HiddenMySub msg) -> List (EncodeValue -> msg) +createIncomingPortConverters : List (HiddenMySub msg) -> List (Encode.Value -> msg) createIncomingPortConverters = Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 196f297f..00490a9c 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -27,7 +27,7 @@ module Platform.Cmd exposing -} import Basics exposing (..) -import Elm.Kernel.Basics +import Elm.Kernel.Platform import List import Platform.Bag as Bag diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 973e59da..78222b73 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -22,10 +22,7 @@ nicer API. `Platform` cannot import `Platform.Scheduler` as -} import Basics exposing (..) -import Debug -import Elm.Kernel.Basics import Elm.Kernel.Scheduler -import List exposing ((::)) import Maybe exposing (Maybe(..)) @@ -200,7 +197,7 @@ enqueue id = let (ProcessState _) = updateProcessState - (\(ProcessState p) -> + (\(ProcessState _) -> ProcessState (Ready newRoot) ) procId diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index c6ce4a6b..56774389 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -136,7 +136,7 @@ spawn = (\task -> RawScheduler.andThen (\proc -> RawScheduler.Value (Ok (wrapProcessId proc))) - (RawScheduler.spawn (\msg state -> never msg) task) + (RawScheduler.spawn (\msg _ -> never msg) task) ) @@ -149,7 +149,7 @@ rawSpawn : Platform.Task err ok -> Platform.ProcessId rawSpawn = taskFn (\task -> - wrapProcessId (RawScheduler.rawSpawn (\msg state -> never msg) task (RawScheduler.newProcessId ())) + wrapProcessId (RawScheduler.rawSpawn (\msg _ -> never msg) task (RawScheduler.newProcessId ())) ) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index eaeea2a4..55b42fbb 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -27,7 +27,7 @@ module Platform.Sub exposing -} import Basics exposing (..) -import Elm.Kernel.Basics +import Elm.Kernel.Platform import List import Platform.Bag as Bag diff --git a/src/Process.elm b/src/Process.elm index 7deaaf1f..1b9bfeb0 100644 --- a/src/Process.elm +++ b/src/Process.elm @@ -43,8 +43,7 @@ longer. That’s kind of what Elm is all about. -} -import Basics exposing (..) -import Debug +import Basics exposing (Float) import Platform import Platform.Scheduler as Scheduler import Task exposing (Task) diff --git a/src/Task.elm b/src/Task.elm index 787d4290..c653d318 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -30,7 +30,7 @@ HTTP requests or writing to a database. -} -import Basics exposing ((<<), (|>), Never) +import Basics exposing ((<<), (|>), Never, never) import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform @@ -393,15 +393,15 @@ init = onEffects : Platform.Router msg Never -> List (MyCmd msg) -> () -> Task Never () -onEffects router commands state = +onEffects router commands () = map (\_ -> ()) (sequence (List.map (spawnCmd router) commands)) onSelfMsg : Platform.Router msg Never -> Never -> () -> Task Never () -onSelfMsg _ _ _ = - succeed () +onSelfMsg _ msg () = + never msg spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x Platform.ProcessId From 5f880d0be180d562f3bc28ffcac1fc4eb421fa18 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 2 Jan 2020 23:45:49 +0000 Subject: [PATCH 063/170] use modern js in basics.js --- src/Elm/Kernel/Basics.js | 45 ++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 25 deletions(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 9b06b04c..fc05521e 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -6,31 +6,26 @@ import Elm.Kernel.Debug exposing (crash) // MATH -var _Basics_pow = F2(Math.pow); - -var _Basics_cos = Math.cos; -var _Basics_sin = Math.sin; -var _Basics_tan = Math.tan; -var _Basics_acos = Math.acos; -var _Basics_asin = Math.asin; -var _Basics_atan = Math.atan; -var _Basics_atan2 = F2(Math.atan2); - - -var _Basics_ceiling = Math.ceil; -var _Basics_floor = Math.floor; -var _Basics_round = Math.round; -var _Basics_sqrt = Math.sqrt; -var _Basics_log = Math.log; - -var _Basics_modBy0 = function() -{ - __Debug_crash(11) -}; - -var _Basics_fudgeType = function(x) { - return x; -}; +const _Basics_pow = F2(Math.pow); + +const _Basics_cos = Math.cos; +const _Basics_sin = Math.sin; +const _Basics_tan = Math.tan; +const _Basics_acos = Math.acos; +const _Basics_asin = Math.asin; +const _Basics_atan = Math.atan; +const _Basics_atan2 = F2(Math.atan2); + + +const _Basics_ceiling = Math.ceil; +const _Basics_floor = Math.floor; +const _Basics_round = Math.round; +const _Basics_sqrt = Math.sqrt; +const _Basics_log = Math.log; + +const _Basics_modBy0 = () => __Debug_crash(11); + +const _Basics_fudgeType = x => x; const _Basics_unwrapTypeWrapper__DEBUG = wrapped => { const entries = Object.entries(wrapped); From e31990916b7c4cf7718f8289a103737f13b3dfbe Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 2 Jan 2020 23:47:36 +0000 Subject: [PATCH 064/170] define List in elm and minimise kernel code We keep kernel code for converting to and from js arrays (the compiler may call these kernel functions) and the Nil and Cons functions. The Nil and Cons functions remain because a) code in elm/* packages (e.g. elm/json) use these functions and b) because some kernel code that runs on page load is placed above the js generated for elm/core:List and so cannot use the elm definitions (they will be undefined). --- src/Elm/Kernel/Debug.js | 2 +- src/Elm/Kernel/List.js | 112 +++++++++++++-------------------------- src/Elm/Kernel/String.js | 5 +- src/List.elm | 24 ++++++--- 4 files changed, 59 insertions(+), 84 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 06c62d67..0c1c89fb 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -118,7 +118,7 @@ function _Debug_toAnsiString(ansi, value) + _Debug_toAnsiString(ansi, __Array_toList(value)); } - if (tag === '::' || tag === '[]') + if (tag === 'Cons_elm_builtin' || tag === 'Nil_elm_builtin') { var output = '['; diff --git a/src/Elm/Kernel/List.js b/src/Elm/Kernel/List.js index 2441718b..ae8a3162 100644 --- a/src/Elm/Kernel/List.js +++ b/src/Elm/Kernel/List.js @@ -2,85 +2,47 @@ import Elm.Kernel.Utils exposing (cmp) import Basics exposing (EQ, LT) +import List exposing (Nil_elm_builtin, Cons_elm_builtin) */ - -var _List_Nil__PROD = { $: 0 }; -var _List_Nil__DEBUG = { $: '[]' }; - -function _List_Cons__PROD(hd, tl) { return { $: 1, a: hd, b: tl }; } -function _List_Cons__DEBUG(hd, tl) { return { $: '::', a: hd, b: tl }; } - - -var _List_cons = F2(_List_Cons); - -function _List_fromArray(arr) -{ - var out = _List_Nil; - for (var i = arr.length; i--; ) - { - out = _List_Cons(arr[i], out); - } - return out; -} - -function _List_toArray(xs) -{ - for (var out = []; xs.b; xs = xs.b) // WHILE_CONS - { +/* Ideally we would write + * + * ``` + * const \_List_Nil = \_\_List_Nil; + * ``` + * + * to forward this call `elm/core:List.Nil_elm_builtin` however the elm + * compiler puts the javascript for `elm/core:List.Nil_elm_builtin` after the + * javascript below in the elm.js file and so with the above definition we get + * "XXX is undefined" errors. + * + */ +const _List_nilKey__PROD = 0; +const _List_nilKey__DEBUG = 'Nil_elm_builtin'; +const _List_Nil = { $: _List_nilKey }; + +const _List_Cons = (hd, tl) => A2(__List_Cons_elm_builtin, hd, tl); + +const _List_fromArray = arr => arr.reduceRight( + (out, val) => A2(__List_Cons_elm_builtin, val, out), + __List_Nil_elm_builtin +); + +const _List_toArray = xs => { + const out = []; + while (true) { + if (xs.$ === _List_nilKey) { + return out; + } out.push(xs.a); + xs = xs.b; } - return out; -} - -var _List_map2 = F3(function(f, xs, ys) -{ - for (var arr = []; xs.b && ys.b; xs = xs.b, ys = ys.b) // WHILE_CONSES - { - arr.push(A2(f, xs.a, ys.a)); - } - return _List_fromArray(arr); -}); - -var _List_map3 = F4(function(f, xs, ys, zs) -{ - for (var arr = []; xs.b && ys.b && zs.b; xs = xs.b, ys = ys.b, zs = zs.b) // WHILE_CONSES - { - arr.push(A3(f, xs.a, ys.a, zs.a)); - } - return _List_fromArray(arr); -}); - -var _List_map4 = F5(function(f, ws, xs, ys, zs) -{ - for (var arr = []; ws.b && xs.b && ys.b && zs.b; ws = ws.b, xs = xs.b, ys = ys.b, zs = zs.b) // WHILE_CONSES - { - arr.push(A4(f, ws.a, xs.a, ys.a, zs.a)); - } - return _List_fromArray(arr); -}); - -var _List_map5 = F6(function(f, vs, ws, xs, ys, zs) -{ - for (var arr = []; vs.b && ws.b && xs.b && ys.b && zs.b; vs = vs.b, ws = ws.b, xs = xs.b, ys = ys.b, zs = zs.b) // WHILE_CONSES - { - arr.push(A5(f, vs.a, ws.a, xs.a, ys.a, zs.a)); - } - return _List_fromArray(arr); -}); - -var _List_sortBy = F2(function(f, xs) -{ - return _List_fromArray(_List_toArray(xs).sort(function(a, b) { - return __Utils_cmp(f(a), f(b)); - })); -}); +}; -var _List_sortWith = F2(function(f, xs) -{ - return _List_fromArray(_List_toArray(xs).sort(function(a, b) { - var ord = A2(f, a, b); +const _List_sortWith = F2((f, xs) => + _List_fromArray(_List_toArray(xs).sort((a, b) => { + const ord = A2(f, a, b); return ord === __Basics_EQ ? 0 : ord === __Basics_LT ? -1 : 1; - })); -}); + })) +); diff --git a/src/Elm/Kernel/String.js b/src/Elm/Kernel/String.js index 1a005e7f..13f49318 100644 --- a/src/Elm/Kernel/String.js +++ b/src/Elm/Kernel/String.js @@ -1,8 +1,9 @@ /* -import Elm.Kernel.List exposing (fromArray, toArray, Nil) +import Elm.Kernel.List exposing (fromArray, toArray) import Elm.Kernel.Utils exposing (chr, Tuple2) import Maybe exposing (Just, Nothing) +import List exposing (Nil_elm_builtin) */ @@ -249,7 +250,7 @@ var _String_indexes = F2(function(sub, str) if (subLen < 1) { - return __List_Nil; + return __List_Nil_elm_builtin; } var i = 0; diff --git a/src/List.elm b/src/List.elm index f6502c7d..a16a07b4 100644 --- a/src/List.elm +++ b/src/List.elm @@ -7,9 +7,9 @@ module List exposing , isEmpty, head, tail, take, drop, partition, unzip ) -{-| You can create a `List` in Elm with the `[1,2,3]` syntax, so lists are -used all over the place. This module has a bunch of functions to help you work -with them! +{-| You can create a `List` in Elm with the `[1,2,3]` syntax, so lists are used +all over the place. This module has a bunch of functions to help you work with +them! # Create @@ -41,6 +41,13 @@ with them! @docs isEmpty, head, tail, take, drop, partition, unzip + +# Future work + +Benchmark the mapN functions and sortBy. Optimise to get comparible performance +with the official elm/core implementation. (This official elm/core +implementation uses kernel code.) + -} import Basics exposing (..) @@ -51,6 +58,11 @@ import Maybe exposing (Maybe(..)) infix right 5 (::) = cons +type List a + = Nil_elm_builtin + | Cons_elm_builtin a (List a) + + -- CREATE @@ -122,7 +134,7 @@ of it like pushing an entry onto a stack. -} cons : a -> List a -> List a cons = - Elm.Kernel.List.cons + Cons_elm_builtin @@ -583,8 +595,8 @@ sort xs = -} sortBy : (a -> comparable) -> List a -> List a -sortBy = - Elm.Kernel.List.sortBy +sortBy f = + sortWith (\a b -> compare (f a) (f b)) {-| Sort values with a custom comparison function. From ef7293be82c6b1e823726b41735d7a341ae51c3d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 3 Jan 2020 19:54:16 +0000 Subject: [PATCH 065/170] tidy utils.js --- src/Basics.elm | 13 ++- src/Elm/Kernel/List.js | 1 - src/Elm/Kernel/Utils.js | 152 ++++++++++++++++++------------------ tests/tests/Test/Basics.elm | 2 + 4 files changed, 87 insertions(+), 81 deletions(-) diff --git a/src/Basics.elm b/src/Basics.elm index 578d3ecc..5f208799 100644 --- a/src/Basics.elm +++ b/src/Basics.elm @@ -566,8 +566,17 @@ are also the only values that work as `Dict` keys or `Set` members. -} compare : comparable -> comparable -> Order -compare = - Elm.Kernel.Utils.compare +compare x y = + let + compared : Int + compared = Elm.Kernel.Utils.compare x y + in + if lt compared 0 then + LT + else if eq compared 0 then + EQ + else + GT {-| Represents the relative ordering of two things. diff --git a/src/Elm/Kernel/List.js b/src/Elm/Kernel/List.js index ae8a3162..c084a7e4 100644 --- a/src/Elm/Kernel/List.js +++ b/src/Elm/Kernel/List.js @@ -1,6 +1,5 @@ /* -import Elm.Kernel.Utils exposing (cmp) import Basics exposing (EQ, LT) import List exposing (Nil_elm_builtin, Cons_elm_builtin) diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index 951dff4b..e2409d3b 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -6,22 +6,23 @@ import Dict exposing (toList) import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.List exposing (Cons, Nil) import Set exposing (toList) +import List exposing (append) */ // EQUALITY -function _Utils_eq(x, y) -{ - for ( - var pair, stack = [], isEqual = _Utils_eqHelp(x, y, 0, stack); - isEqual && (pair = stack.pop()); - isEqual = _Utils_eqHelp(pair.a, pair.b, 0, stack) - ) - {} - - return isEqual; +const _Utils_eq = (x, y) => { + const stack = []; + while(_Utils_eqHelp(x, y, 0, stack)) { + const pair = stack.pop(); + if (pair === undefined) { + return true; + } + [x, y] = pair; + } + return false; } function _Utils_eqHelp(x, y, depth, stack) @@ -33,13 +34,15 @@ function _Utils_eqHelp(x, y, depth, stack) if (typeof x !== 'object' || x === null || y === null) { - typeof x === 'function' && __Debug_crash(5); + if (typeof x === 'function') { + __Debug_crash(5); + } return false; } if (depth > 100) { - stack.push(_Utils_Tuple2(x,y)); + stack.push([x,y]); return true; } @@ -64,33 +67,38 @@ function _Utils_eqHelp(x, y, depth, stack) } //*/ - for (var key in x) + /* The compiler ensures that the elm types of x and y are the same. + * Therefore, x and y must have the same keys. + */ + for (const key of Object.keys(x)) { - if (!_Utils_eqHelp(x[key], y[key], depth + 1, stack)) - { + if (!_Utils_eqHelp(x[key], y[key], depth + 1, stack)) { return false; } } return true; } -var _Utils_equal = F2(_Utils_eq); -var _Utils_notEqual = F2(function(a, b) { return !_Utils_eq(a,b); }); +const _Utils_equal = F2(_Utils_eq); +const _Utils_notEqual = F2(function(a, b) { return !_Utils_eq(a,b); }); // COMPARISONS -// Code in Generate/JavaScript.hs, Basics.js, and List.js depends on -// the particular integer values assigned to LT, EQ, and GT. - +// Code in Generate/JavaScript/Expression.hs and Basics.elm depends on the +// particular integer values assigned to LT, EQ, and GT. Comparable types are: +// numbers, characters, strings, lists of comparable things, and tuples of +// comparable things. function _Utils_cmp(x, y, ord) { + // Handle numbers, strings and characters in production mode. if (typeof x !== 'object') { return x === y ? /*EQ*/ 0 : x < y ? /*LT*/ -1 : /*GT*/ 1; } + // Handle characters in debug mode. /**__DEBUG/ if (x instanceof String) { @@ -100,6 +108,7 @@ function _Utils_cmp(x, y, ord) } //*/ + // Handle tuples. /**__PROD/ if (typeof x.$ === 'undefined') //*/ @@ -107,71 +116,68 @@ function _Utils_cmp(x, y, ord) if (x.$[0] === '#') //*/ { - return (ord = _Utils_cmp(x.a, y.a)) - ? ord - : (ord = _Utils_cmp(x.b, y.b)) - ? ord - : _Utils_cmp(x.c, y.c); + const ordA = _Utils_cmp(x.a, y.a); + if (ordA !== 0) { + return ordA; + } + const ordB = _Utils_cmp(x.a, y.a); + if (ordB !== 0) { + return ordB; + } + return _Utils_cmp(x.c, y.c); } - // traverse conses until end of a list or a mismatch - for (; x.b && y.b && !(ord = _Utils_cmp(x.a, y.a)); x = x.b, y = y.b) {} // WHILE_CONSES - return ord || (x.b ? /*GT*/ 1 : y.b ? /*LT*/ -1 : /*EQ*/ 0); + // Handle lists: traverse conses until end of a list or a mismatch. If the + // all the elements in one list are equal to all the elements in other list + // but the first list is longer than the first list is greater (and visa + // versa). + while(true) { + if (x.$ === _List_nilKey) { + if (y.$ === _List_nilKey) { + return 0; + } else { + return -1; + } + } else if (y.$ === _List_nilKey) { + return 1; + } + const ord = _Utils_cmp(x.a, y.a); + if (ord !== 0) { + return ord; + } + x = x.b; + y = y.b; + } } -var _Utils_lt = F2(function(a, b) { return _Utils_cmp(a, b) < 0; }); -var _Utils_le = F2(function(a, b) { return _Utils_cmp(a, b) < 1; }); -var _Utils_gt = F2(function(a, b) { return _Utils_cmp(a, b) > 0; }); -var _Utils_ge = F2(function(a, b) { return _Utils_cmp(a, b) >= 0; }); - -var _Utils_compare = F2(function(x, y) -{ - var n = _Utils_cmp(x, y); - return n < 0 ? __Basics_LT : n ? __Basics_GT : __Basics_EQ; -}); - +const _Utils_compare = F2((x, y) => _Utils_cmp(x, y)); // COMMON VALUES -var _Utils_Tuple0__PROD = 0; -var _Utils_Tuple0__DEBUG = { $: '#0' }; +const _Utils_Tuple0__PROD = 0; +const _Utils_Tuple0__DEBUG = { $: '#0' }; -function _Utils_Tuple2__PROD(a, b) { return { a: a, b: b }; } -function _Utils_Tuple2__DEBUG(a, b) { return { $: '#2', a: a, b: b }; } +const _Utils_Tuple2__PROD = (a, b) => ({ a, b }); +const _Utils_Tuple2__DEBUG = (a, b) => ({ $: '#2', a, b }); -function _Utils_Tuple3__PROD(a, b, c) { return { a: a, b: b, c: c }; } -function _Utils_Tuple3__DEBUG(a, b, c) { return { $: '#3', a: a, b: b, c: c }; } +const _Utils_Tuple3__PROD = (a, b, c) => ({ a, b, c }); +const _Utils_Tuple3__DEBUG = (a, b, c) => ({ $: '#3', a, b, c }); -function _Utils_chr__PROD(c) { return c; } -function _Utils_chr__DEBUG(c) { return new String(c); } +const _Utils_chr__PROD = c => c; +const _Utils_chr__DEBUG = c => new String(c); // RECORDS -function _Utils_update(oldRecord, updatedFields) -{ - var newRecord = {}; - - for (var key in oldRecord) - { - newRecord[key] = oldRecord[key]; - } - - for (var key in updatedFields) - { - newRecord[key] = updatedFields[key]; - } - - return newRecord; -} +const _Utils_update = (oldRecord, updatedFields) => Object.assign( + {}, + oldRecord, + updatedFields); // APPEND -var _Utils_append = F2(_Utils_ap); - -function _Utils_ap(xs, ys) -{ +const _Utils_ap = (xs, ys) => { // append Strings if (typeof xs === 'string') { @@ -179,15 +185,5 @@ function _Utils_ap(xs, ys) } // append Lists - if (!xs.b) - { - return ys; - } - var root = __List_Cons(xs.a, ys); - xs = xs.b - for (var curr = root; xs.b; xs = xs.b) // WHILE_CONS - { - curr = curr.b = __List_Cons(xs.a, ys); - } - return root; + return A2(__List_append, xs, ys); } diff --git a/tests/tests/Test/Basics.elm b/tests/tests/Test/Basics.elm index bae9b52c..bcc72621 100644 --- a/tests/tests/Test/Basics.elm +++ b/tests/tests/Test/Basics.elm @@ -36,6 +36,8 @@ tests = , test "compare 'f' 'f'" <| \() -> Expect.equal EQ (compare 'f' 'f') , test "compare (1, 2, 3) (0, 1, 2)" <| \() -> Expect.equal GT (compare ( 1, 2, 3 ) ( 0, 1, 2 )) , test "compare ['a'] ['b']" <| \() -> Expect.equal LT (compare [ 'a' ] [ 'b' ]) + , test "compare [ 2 ] [ 2, 1]" <| \() -> Expect.equal LT (compare [ 2 ] [ 2, 1 ]) + , test "compare [ 1, 2 ] [ 1.5 ]" <| \() -> Expect.equal LT (compare [ 1, 2 ] [ 1.5 ]) , test "array equality" <| \() -> Expect.equal (Array.fromList [ 1, 1, 1, 1 ]) (Array.repeat 4 1) , test "set equality" <| \() -> Expect.equal (Set.fromList [ 1, 2 ]) (Set.fromList [ 2, 1 ]) , test "dict equality" <| \() -> Expect.equal (Dict.fromList [ ( 1, 1 ), ( 2, 2 ) ]) (Dict.fromList [ ( 2, 2 ), ( 1, 1 ) ]) From 45857e92b7fe4adc010f892bab3698666e1c35ab Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 3 Jan 2020 20:04:50 +0000 Subject: [PATCH 066/170] simply scheduler by removing ProcessRoot type --- src/Platform/RawScheduler.elm | 33 ++++++++++++--------------------- 1 file changed, 12 insertions(+), 21 deletions(-) diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 78222b73..bc1896f9 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -40,15 +40,11 @@ type alias TryAbortAction = () -> () -type ProcessRoot state +type ProcessState msg state = Ready (Task state) | Running TryAbortAction -type ProcessState msg state - = ProcessState (ProcessRoot state) - - type ProcessId msg = ProcessId { id : UniqueId } @@ -100,7 +96,7 @@ rawSpawn receiver initTask processId = (registerNewProcess processId receiver - (ProcessState (Ready initTask)) + (Ready initTask) ) @@ -164,11 +160,8 @@ kill processId = SyncAction (\() -> let - (ProcessState root) = - getProcessState processId - () = - case root of + case getProcessState processId of Running killer -> killer () @@ -195,11 +188,9 @@ enqueue id = runOnNextTick (\newRoot -> let - (ProcessState _) = + _ = updateProcessState - (\(ProcessState _) -> - ProcessState (Ready newRoot) - ) + (\_ -> Ready newRoot) procId in let @@ -209,7 +200,7 @@ enqueue id = () ) - (ProcessState _) = + _ = updateProcessState (stepper procId onAsyncActionDone) procId in () @@ -228,10 +219,10 @@ the process it is passed as an argument -} stepper : ProcessId msg -> (Task state -> ()) -> ProcessState msg state -> ProcessState msg state -stepper processId onAsyncActionDone (ProcessState process) = +stepper processId onAsyncActionDone process = case process of Running _ -> - ProcessState process + process Ready (Value val) -> case mailboxReceive processId val of @@ -239,19 +230,19 @@ stepper processId onAsyncActionDone (ProcessState process) = stepper processId onAsyncActionDone - (ProcessState (Ready newRoot)) + (Ready newRoot) Nothing -> - ProcessState process + process Ready (AsyncAction doEffect) -> - ProcessState (Running (doEffect onAsyncActionDone)) + Running (doEffect onAsyncActionDone) Ready (SyncAction doEffect) -> stepper processId onAsyncActionDone - (ProcessState (Ready (doEffect ()))) + (Ready (doEffect ())) From ace6b42de6ab63407bfdb452d833acd589e3d8ca Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Fri, 3 Jan 2020 21:57:26 +0000 Subject: [PATCH 067/170] tidy runtime --- src/Platform.elm | 130 ++++++++++++++++------------------ src/Platform/RawScheduler.elm | 15 +++- src/Platform/Scheduler.elm | 31 ++++---- 3 files changed, 86 insertions(+), 90 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index f9c246a2..0c14453b 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -102,7 +102,7 @@ worker impl = { stepperBuilder = \_ _ -> \_ _ -> () , setupOutgoingPort = setupOutgoingPort , setupIncomingPort = setupIncomingPort - , setupEffects = instantiateEffectManager + , setupEffects = setupEffects , dispatchEffects = dispatchEffects } ) @@ -148,12 +148,7 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Task - (RawScheduler.SyncAction - (\() -> - RawScheduler.Value (Ok (router.sendToApp msg)) - ) - ) + Task (RawScheduler.SyncAction (\() -> RawScheduler.Value (Ok (router.sendToApp msg)))) {-| Send the router a message for your effect manager. This message will @@ -165,14 +160,7 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.send - router.selfProcess - (Self msg) - ) - ) + Task (RawScheduler.map Ok (RawScheduler.send router.selfProcess (Self msg))) @@ -183,37 +171,30 @@ setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData setupOutgoingPort outgoingPortSend = let init = - Task (RawScheduler.Value (Ok ())) + RawScheduler.Value () onSelfMsg _ selfMsg () = never selfMsg - execInOrder : List Encode.Value -> RawScheduler.Task (Result Never ()) - execInOrder cmdList = - case cmdList of - first :: rest -> - RawScheduler.SyncAction - (\() -> - let - _ = - outgoingPortSend first - in - execInOrder rest - ) - - _ -> - RawScheduler.Value (Ok ()) - onEffects : Router Never Never -> List (HiddenMyCmd Never) -> List (HiddenMySub Never) -> () - -> Task Never () + -> RawScheduler.Task () onEffects _ cmdList _ () = - Task (execInOrder (createValuesToSendOutOfPorts cmdList)) + RawScheduler.execImpure + (\() -> + let + _ = + cmdList + |> createValuesToSendOutOfPorts + |> List.map outgoingPortSend + in + () + ) in - instantiateEffectManager (\msg -> never msg) init onEffects onSelfMsg + instantiateEffectManager never init onEffects onSelfMsg setupIncomingPort : @@ -223,22 +204,13 @@ setupIncomingPort : setupIncomingPort sendToApp2 updateSubs = let init = - Task (RawScheduler.Value (Ok ())) + RawScheduler.Value () onSelfMsg _ selfMsg () = never selfMsg onEffects _ _ subList () = - Task - (RawScheduler.SyncAction - (\() -> - let - _ = - updateSubs subList - in - RawScheduler.Value (Ok ()) - ) - ) + RawScheduler.execImpure (\() -> updateSubs subList) onSend value subs = List.foldr @@ -338,39 +310,43 @@ createEffect isCmd newEffect maybeEffects = ( cmdList, newEffect :: subList ) -instantiateEffectManager : +setupEffects : SendToApp appMsg -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) -instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = +setupEffects sendToAppFunc init onEffects onSelfMsg = + instantiateEffectManager + sendToAppFunc + (unwrapTask init) + (\router cmds subs state -> unwrapTask (onEffects router cmds subs state)) + (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) + + +instantiateEffectManager : + SendToApp appMsg + -> RawScheduler.Task state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state) + -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) +instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let - receiver msg stateRes = + receiver msg state = let - (Task task) = - case stateRes of - Ok state -> - case msg of - Self value -> - onSelfMsg router value state - - App cmds subs -> - onEffects router cmds subs state - - Err e -> - never e + task = + case msg of + Self value -> + onSelfMsg router value state + + App cmds subs -> + onEffects router cmds subs state in RawScheduler.andThen - (\res -> - case res of - Ok val -> - RawScheduler.andThen - (\() -> RawScheduler.Value (Ok val)) - (RawScheduler.sleep 0) - - Err e -> - never e + (\val -> + RawScheduler.map + (\() -> val) + (RawScheduler.sleep 0) ) task @@ -391,6 +367,20 @@ instantiateEffectManager sendToAppFunc (Task init) onEffects onSelfMsg = RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId +unwrapTask : Task Never a -> RawScheduler.Task a +unwrapTask (Task task) = + RawScheduler.map + (\res -> + case res of + Ok val -> + val + + Err x -> + never x + ) + task + + type alias SendToApp msg = msg -> UpdateMetadata -> () diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index bc1896f9..48ef6768 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, kill, newProcessId, rawSend, rawSpawn, send, sleep, spawn) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) {-| This module contains the low level logic for running tasks and processes. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -70,6 +70,19 @@ andThen func task = ) +{-| Create a task that executes a non pure function +-} +execImpure : (() -> a) -> Task a +execImpure func = + SyncAction + (\() -> Value (func ())) + + +map : (a -> b) -> Task a -> Task b +map func = + andThen (\x -> Value (func x)) + + {-| Create a new, unique, process id. Will not register the new process id, just create it. To run any tasks using diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 56774389..b4e15dfa 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -118,11 +118,7 @@ onError func = -} send : ProcessId msg -> msg -> Platform.Task never () send proc msg = - wrapTask - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.send proc msg) - ) + wrapTask (RawScheduler.map Ok (RawScheduler.send proc msg)) {-| Create a task that, when run, will spawn a process. @@ -134,13 +130,13 @@ spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId spawn = wrapTaskFn (\task -> - RawScheduler.andThen - (\proc -> RawScheduler.Value (Ok (wrapProcessId proc))) + RawScheduler.map + (\proc -> Ok (wrapProcessId proc)) (RawScheduler.spawn (\msg _ -> never msg) task) ) -{-| This is provided to make \_\_Schdeuler\_rawSpawn work! +{-| This is provided to make `__Scheduler_rawSpawn` work! TODO(harry) remove once code in other `elm/*` packages has been updated. @@ -149,7 +145,12 @@ rawSpawn : Platform.Task err ok -> Platform.ProcessId rawSpawn = taskFn (\task -> - wrapProcessId (RawScheduler.rawSpawn (\msg _ -> never msg) task (RawScheduler.newProcessId ())) + wrapProcessId + (RawScheduler.rawSpawn + (\msg _ -> never msg) + task + (RawScheduler.newProcessId ()) + ) ) @@ -157,22 +158,14 @@ rawSpawn = -} kill : Platform.ProcessId -> Platform.Task never () kill processId = - wrapTask - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.kill (unwrapProcessId processId)) - ) + wrapTask (RawScheduler.map Ok (RawScheduler.kill (unwrapProcessId processId))) {-| Create a task that sleeps for `time` milliseconds -} sleep : Float -> Platform.Task x () sleep time = - wrapTask - (RawScheduler.andThen - (\() -> RawScheduler.Value (Ok ())) - (RawScheduler.sleep time) - ) + wrapTask (RawScheduler.map Ok (RawScheduler.sleep time)) From 01b48b0ec1db6921f11667d85e1e47be2a198819 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 8 Jan 2020 21:49:07 +0000 Subject: [PATCH 068/170] stop running each test twice --- tests/run-tests.sh | 4 ++-- tests/tests/Main.elm | 40 ---------------------------------------- 2 files changed, 2 insertions(+), 42 deletions(-) delete mode 100644 tests/tests/Main.elm diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 2be66367..fe77659b 100755 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -40,7 +40,7 @@ echo "seeding framework for test dependencies ..."; # useful when developing a fix for a bug that exists in the version of # elm/core hosted on package.elm-lang.org -"${ELM_TEST}" tests/Main.elm --fuzz=1 > /dev/null || true; +"${ELM_TEST}" --fuzz=1 > /dev/null || true; # elm make tests/Main2.elm --output ./tmp.js @@ -70,4 +70,4 @@ echo; echo "running tests ..."; echo; -"${ELM_TEST}" tests/Main.elm "$@"; +"${ELM_TEST}" "$@"; diff --git a/tests/tests/Main.elm b/tests/tests/Main.elm deleted file mode 100644 index 51bef482..00000000 --- a/tests/tests/Main.elm +++ /dev/null @@ -1,40 +0,0 @@ -module Main exposing (..) - -import Basics exposing (..) -import Task exposing (..) -import Test exposing (..) -import Platform.Cmd exposing (Cmd) -import Json.Decode exposing (Value) -import Test.Runner.Node exposing (run, TestProgram) -import Test.Array as Array -import Test.Basics as Basics -import Test.Bitwise as Bitwise -import Test.Char as Char -import Test.CodeGen as CodeGen -import Test.Dict as Dict -import Test.Maybe as Maybe -import Test.Equality as Equality -import Test.List as List -import Test.Result as Result -import Test.Set as Set -import Test.String as String -import Test.Tuple as Tuple - - -tests : Test -tests = - describe "Elm Standard Library Tests" - [ Array.tests - , Basics.tests - , Bitwise.tests - , Char.tests - , CodeGen.tests - , Dict.tests - , Equality.tests - , List.tests - , Result.tests - , Set.tests - , String.tests - , Maybe.tests - , Tuple.tests - ] From e0a16222e49bae7501f953f516dc8d49e2c23b18 Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Mon, 10 Feb 2020 16:01:28 +0000 Subject: [PATCH 069/170] Add workflows to set expectations about issues and pull requests --- .github/workflows/set-issue-expectations.yml | 19 +++++++++++++++++++ .github/workflows/set-pull-expectations.yml | 19 +++++++++++++++++++ 2 files changed, 38 insertions(+) create mode 100644 .github/workflows/set-issue-expectations.yml create mode 100644 .github/workflows/set-pull-expectations.yml diff --git a/.github/workflows/set-issue-expectations.yml b/.github/workflows/set-issue-expectations.yml new file mode 100644 index 00000000..2afe0092 --- /dev/null +++ b/.github/workflows/set-issue-expectations.yml @@ -0,0 +1,19 @@ +name: Set Issue Expectations +on: + issues: + types: [opened] +jobs: + comment-on-issue: + name: Comment On Issue + runs-on: ubuntu-latest + steps: + - uses: actions/github@v1.0.0 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + args: | + comment "Thanks for reporting this! To set expectations: + - Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response. + - Ask questions a [community forum](https://elm-lang.org/community). You will get an answer quicker that way! + - If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md). + Finally, please be patient with the core team. They are trying their best with limited resources." diff --git a/.github/workflows/set-pull-expectations.yml b/.github/workflows/set-pull-expectations.yml new file mode 100644 index 00000000..f55b9020 --- /dev/null +++ b/.github/workflows/set-pull-expectations.yml @@ -0,0 +1,19 @@ +name: Set Pull Expectations +on: + pull_request: + types: [opened] +jobs: + comment-on-pull: + name: Comment On Pull + runs-on: ubuntu-latest + steps: + - uses: actions/github@v1.0.0 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + args: | + comment "Thanks for suggesting these code changes. To set expectations: + - Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response. + - Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md). + - Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc. + Finally, please be patient with the core team. They are trying their best with limited resources." From 0b753659b9cb8c88f49df237a971fd037fa43f1d Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Fri, 14 Feb 2020 14:07:23 +0000 Subject: [PATCH 070/170] fix missing scope declaration on variable --- src/Elm/Kernel/Platform.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index d28ab33f..ed825dc4 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -44,7 +44,7 @@ function _Platform_initialize(flagDecoder, args, init, update, subscriptions, st function sendToApp(msg, viewMetadata) { - result = A2(update, msg, model); + var result = A2(update, msg, model); stepper(model = result.a, viewMetadata); _Platform_enqueueEffects(managers, result.b, subscriptions(model)); } From ccd61a7047e6b568308485935e6ed557f36c3c43 Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Fri, 14 Feb 2020 17:01:07 -0500 Subject: [PATCH 071/170] stop shadowing a variable name in the outer scope --- src/Elm/Kernel/Platform.js | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index ed825dc4..2cc634b6 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -44,9 +44,9 @@ function _Platform_initialize(flagDecoder, args, init, update, subscriptions, st function sendToApp(msg, viewMetadata) { - var result = A2(update, msg, model); - stepper(model = result.a, viewMetadata); - _Platform_enqueueEffects(managers, result.b, subscriptions(model)); + var pair = A2(update, msg, model); + stepper(model = pair.a, viewMetadata); + _Platform_enqueueEffects(managers, pair.b, subscriptions(model)); } _Platform_enqueueEffects(managers, result.b, subscriptions(model)); From 6503eaf66f4b0a1cfeab30996f55f8c333d0eaed Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Fri, 14 Feb 2020 17:02:49 -0500 Subject: [PATCH 072/170] stop reusing a variable for the pair produced by init --- src/Elm/Kernel/Platform.js | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 2cc634b6..d3cf8db0 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -37,8 +37,8 @@ function _Platform_initialize(flagDecoder, args, init, update, subscriptions, st var result = A2(__Json_run, flagDecoder, __Json_wrap(args ? args['flags'] : undefined)); __Result_isOk(result) || __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); var managers = {}; - result = init(result.a); - var model = result.a; + var initPair = init(result.a); + var model = initPair.a; var stepper = stepperBuilder(sendToApp, model); var ports = _Platform_setupEffects(managers, sendToApp); @@ -49,7 +49,7 @@ function _Platform_initialize(flagDecoder, args, init, update, subscriptions, st _Platform_enqueueEffects(managers, pair.b, subscriptions(model)); } - _Platform_enqueueEffects(managers, result.b, subscriptions(model)); + _Platform_enqueueEffects(managers, initPair.b, subscriptions(model)); return ports ? { ports: ports } : {}; } From 84f38891468e8e153fc85a9b63bdafd81b24664e Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Sat, 15 Feb 2020 12:19:04 -0500 Subject: [PATCH 073/170] bump to 1.0.5 for synchronous event fix --- elm.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elm.json b/elm.json index 2045963d..64bcf9a5 100644 --- a/elm.json +++ b/elm.json @@ -3,7 +3,7 @@ "name": "elm/core", "summary": "Elm's standard libraries", "license": "BSD-3-Clause", - "version": "1.0.4", + "version": "1.0.5", "exposed-modules": { "Primitives": [ "Basics", From ae911cfe7b9c0a610cb65970173c40ad545e336d Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Fri, 21 Feb 2020 14:36:01 -0500 Subject: [PATCH 074/170] add newlines to get formatting right --- .github/workflows/set-issue-expectations.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/set-issue-expectations.yml b/.github/workflows/set-issue-expectations.yml index 2afe0092..da03493f 100644 --- a/.github/workflows/set-issue-expectations.yml +++ b/.github/workflows/set-issue-expectations.yml @@ -13,7 +13,9 @@ jobs: with: args: | comment "Thanks for reporting this! To set expectations: + - Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response. - Ask questions a [community forum](https://elm-lang.org/community). You will get an answer quicker that way! - If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md). + Finally, please be patient with the core team. They are trying their best with limited resources." From 22eefd207e7a63daab215ae497f683ff2319c2ca Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Fri, 21 Feb 2020 14:36:46 -0500 Subject: [PATCH 075/170] add newlines to get formatting right --- .github/workflows/set-pull-expectations.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/set-pull-expectations.yml b/.github/workflows/set-pull-expectations.yml index f55b9020..63813f6b 100644 --- a/.github/workflows/set-pull-expectations.yml +++ b/.github/workflows/set-pull-expectations.yml @@ -13,7 +13,9 @@ jobs: with: args: | comment "Thanks for suggesting these code changes. To set expectations: + - Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response. - Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md). - Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc. + Finally, please be patient with the core team. They are trying their best with limited resources." From 842f6bd9eaedc57f6e5b57b6e8a7f6c96a5b913f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 16 Mar 2020 23:50:18 +0000 Subject: [PATCH 076/170] sketch for processes receiving values via channels --- src/Elm/Kernel/Scheduler.js | 17 ++++++ src/Platform.elm | 37 ++++++------ src/Platform/RawScheduler.elm | 111 +++++++++++++++++++++++++--------- src/Platform/Scheduler.elm | 10 +-- 4 files changed, 124 insertions(+), 51 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 9a1edfe3..a7923543 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -43,6 +43,8 @@ var _Scheduler_processes = new WeakMap(); var _Scheduler_receivers = new WeakMap(); var _Scheduler_mailboxes = new WeakMap(); +const _Scheduler_processInbox = new WeakMap(); + function _Scheduler_getGuid() { return _Scheduler_guid++; } @@ -114,6 +116,21 @@ const _Scheduler_mailboxReceive = F2((procId, state) => { } }); +const _Scheduler_rawTryRecv = F2((procId, state) => { + const inbox = _Scheduler_processInbox.get(procId); + /**__DEBUG/ + if (inbox === undefined) { + __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); + } + //*/ + const msg = inbox.shift(); + if (msg === undefined) { + return __Maybe_Nothing; + } else { + return __Maybe_Just(inbox); + } +}); + var _Scheduler_working = false; var _Scheduler_queue = []; diff --git a/src/Platform.elm b/src/Platform.elm index 0c14453b..c7c91e18 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -49,6 +49,7 @@ import String exposing (String) + -- PROGRAMS @@ -118,7 +119,7 @@ information on this. It is only defined here because it is a platform primitive. -} type Task err ok - = Task (RawScheduler.Task (Result err ok)) + = Task (RawScheduler.Task (Result err ok) Never) {-| Head over to the documentation for the [`Process`](Process) module for @@ -126,7 +127,7 @@ information on this. It is only defined here because it is a platform primitive. -} type ProcessId - = ProcessId (RawScheduler.ProcessId Never) + = ProcessId (RawScheduler.ProcessId Never Never) @@ -139,7 +140,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp : appMsg -> () - , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never } @@ -167,7 +168,7 @@ sendToSelf (Router router) msg = -- HELPERS -- -setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) +setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never setupOutgoingPort outgoingPortSend = let init = @@ -181,7 +182,7 @@ setupOutgoingPort outgoingPortSend = -> List (HiddenMyCmd Never) -> List (HiddenMySub Never) -> () - -> RawScheduler.Task () + -> RawScheduler.Task () Never onEffects _ cmdList _ () = RawScheduler.execImpure (\() -> @@ -200,7 +201,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData msg Never) Never, Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -229,7 +230,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never -> () dispatchEffects cmdBag subBag = let @@ -315,7 +316,7 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager sendToAppFunc @@ -326,10 +327,10 @@ setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager : SendToApp appMsg - -> RawScheduler.Task state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state) - -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + -> RawScheduler.Task state Never + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state Never) + -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state Never) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let receiver msg state = @@ -367,7 +368,7 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId -unwrapTask : Task Never a -> RawScheduler.Task a +unwrapTask : Task Never a -> RawScheduler.Task a Never unwrapTask (Task task) = RawScheduler.map (\res -> @@ -400,7 +401,7 @@ type UpdateMetadata type OtherManagers appMsg - = OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) + = OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never)) type ReceivedData appMsg selfMsg @@ -437,22 +438,22 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) + , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData appMsg Never) Never, Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never -> () } diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 48ef6768..83bea293 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -26,34 +26,40 @@ import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) -type Task val +type Task val receive = Value val - | AsyncAction (DoneCallback val -> TryAbortAction) - | SyncAction (() -> Task val) + | AsyncAction (DoneCallback val receive -> TryAbortAction) + | SyncAction (() -> Task val receive) + | Receive (receive -> Task val receive) + | TryReceive (Maybe receive -> Task val receive) -type alias DoneCallback val = - Task val -> () +type alias DoneCallback val receive = + Task val receive -> () type alias TryAbortAction = () -> () -type ProcessState msg state - = Ready (Task state) +type ProcessState receive state + = Ready (Task state receive) | Running TryAbortAction -type ProcessId msg +type ProcessId msg recv = ProcessId { id : UniqueId } +type Channel receive + = Channel + + type UniqueId = UniqueId UniqueId -andThen : (a -> Task b) -> Task a -> Task b +andThen : (a -> Task b receive) -> Task a receive -> Task b receive andThen func task = case task of Value val -> @@ -69,16 +75,43 @@ andThen func task = (\newTask -> doneCallback (andThen func newTask)) ) + Receive receiver -> + Receive + (\message -> + andThen func (receiver message) + ) + + TryReceive receiver -> + TryReceive + (\message -> + andThen func (receiver message) + ) + + +channel : () -> Task (Channel receive) receive +channel () = + Value Channel + + +recv : (receive -> a) -> Channel receive -> Task a receive +recv fn chl = + Receive (\r -> Value (fn r)) + + +tryRecv : (Maybe receive -> a) -> Channel receive -> Task a receive +tryRecv fn chl = + TryReceive (\r -> Value (fn r)) + {-| Create a task that executes a non pure function -} -execImpure : (() -> a) -> Task a +execImpure : (() -> a) -> Task a receive execImpure func = SyncAction (\() -> Value (func ())) -map : (a -> b) -> Task a -> Task b +map : (a -> b) -> Task a receive -> Task b receive map func = andThen (\x -> Value (func x)) @@ -93,7 +126,7 @@ this process before it has been registered will give a **runtime** error. (It may even fail silently in optimized compiles.) -} -newProcessId : () -> ProcessId msg +newProcessId : () -> ProcessId msg recv newProcessId () = ProcessId { id = getGuid () } @@ -103,7 +136,7 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg +rawSpawn : (msg -> a -> Task a Never) -> Task a Never -> ProcessId msg Never -> ProcessId msg Never rawSpawn receiver initTask processId = enqueue (registerNewProcess @@ -122,7 +155,7 @@ If the process is "ready" it will then act upon the next message in its mailbox. -} -rawSend : ProcessId msg -> msg -> ProcessId msg +rawSend : ProcessId msg Never -> msg -> ProcessId msg Never rawSend processId msg = let _ = @@ -133,7 +166,7 @@ rawSend processId msg = {-| Create a task, if run, will make the process deal with a message. -} -send : ProcessId msg -> msg -> Task () +send : ProcessId msg Never -> msg -> Task () receive send processId msg = SyncAction (\() -> @@ -147,7 +180,7 @@ send processId msg = {-| Create a task that spawns a processes. -} -spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) +spawn : (msg -> a -> Task a Never) -> Task a Never -> Task (ProcessId msg Never) Never spawn receiver task = SyncAction (\() -> Value (rawSpawn receiver task (newProcessId ()))) @@ -155,7 +188,7 @@ spawn receiver task = {-| Create a task that sleeps for `time` milliseconds -} -sleep : Float -> Task () +sleep : Float -> Task () receive sleep time = AsyncAction (delay time (Value ())) @@ -164,11 +197,11 @@ sleep time = To kill a process we should try to abort any ongoing async action. We only allow processes that cannot receive messages to be killed, we will -on the offical core library to lead the way regarding processes that can +allow the offical core library to lead the way regarding processes that can receive values. -} -kill : ProcessId Never -> Task () +kill : ProcessId Never Never -> Task () receive kill processId = SyncAction (\() -> @@ -192,7 +225,7 @@ call, drain the run queue but stepping all processes. Returns the enqueued `Process`. -} -enqueue : ProcessId msg -> ProcessId msg +enqueue : ProcessId msg recv -> ProcessId msg recv enqueue id = enqueueWithStepper (\procId -> @@ -231,7 +264,7 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId msg -> (Task state -> ()) -> ProcessState msg state -> ProcessState msg state +stepper : ProcessId msg receive -> (Task state receive -> ()) -> ProcessState receive state -> ProcessState receive state stepper processId onAsyncActionDone process = case process of Running _ -> @@ -257,6 +290,23 @@ stepper processId onAsyncActionDone process = onAsyncActionDone (Ready (doEffect ())) + Ready (Receive receiver) -> + case rawTryRecv processId of + Just received -> + stepper + processId + onAsyncActionDone + (Ready (receiver received)) + + Nothing -> + process + + Ready (TryReceive receiver) -> + stepper + processId + onAsyncActionDone + (Ready (receiver (rawTryRecv processId))) + -- Kernel function redefinitons -- @@ -267,37 +317,42 @@ getGuid = Elm.Kernel.Scheduler.getGuid -updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state +updateProcessState : (ProcessState recv state -> ProcessState recv state) -> ProcessId msg recv -> ProcessState recv state updateProcessState = Elm.Kernel.Scheduler.updateProcessState -mailboxAdd : msg -> ProcessId msg -> msg +mailboxAdd : msg -> ProcessId msg Never -> msg mailboxAdd = Elm.Kernel.Scheduler.mailboxAdd -mailboxReceive : ProcessId msg -> state -> Maybe (Task state) +mailboxReceive : ProcessId msg recv -> state -> Maybe (Task state recv) mailboxReceive = Elm.Kernel.Scheduler.mailboxReceive -getProcessState : ProcessId msg -> ProcessState msg state +rawTryRecv : ProcessId msg receive -> Maybe receive +rawTryRecv = + Elm.Kernel.Scheduler.rawTryRecv + + +getProcessState : ProcessId msg recv -> ProcessState recv state getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg +registerNewProcess : ProcessId msg recv -> (msg -> state -> Task state recv) -> ProcessState receive state -> ProcessId msg recv registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess -enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg +enqueueWithStepper : (ProcessId msg recv -> ()) -> ProcessId msg recv -> ProcessId msg recv enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper -delay : Float -> Task val -> DoneCallback val -> TryAbortAction +delay : Float -> Task val receive -> DoneCallback val receive -> TryAbortAction delay = Elm.Kernel.Scheduler.delay diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index b4e15dfa..829efcd7 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -51,7 +51,7 @@ import Result exposing (Result(..)) type alias ProcessId msg = - RawScheduler.ProcessId msg + RawScheduler.ProcessId msg Never type alias DoneCallback err ok = @@ -172,22 +172,22 @@ sleep time = -- wrapping helpers -- -wrapTaskFn : (RawScheduler.Task (Result e1 o1) -> RawScheduler.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 +wrapTaskFn : (RawScheduler.Task (Result e1 o1) Never -> RawScheduler.Task (Result e2 o2) Never) -> Platform.Task e1 o1 -> Platform.Task e2 o2 wrapTaskFn fn task = wrapTask (taskFn fn task) -taskFn : (RawScheduler.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a +taskFn : (RawScheduler.Task (Result e1 o1) Never -> a) -> Platform.Task e1 o1 -> a taskFn fn task = fn (unwrapTask task) -wrapTask : RawScheduler.Task (Result e o) -> Platform.Task e o +wrapTask : RawScheduler.Task (Result e o) Never -> Platform.Task e o wrapTask = Elm.Kernel.Platform.wrapTask -unwrapTask : Platform.Task e o -> RawScheduler.Task (Result e o) +unwrapTask : Platform.Task e o -> RawScheduler.Task (Result e o) Never unwrapTask = Elm.Kernel.Basics.unwrapTypeWrapper From 770e8bd1c33b701998398e07a977d2ab5f118150 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Mar 2020 20:14:28 +0000 Subject: [PATCH 077/170] a WIP attempt to use new Tasks in Platform --- src/Platform.elm | 30 ++++++++++++++++++++---------- src/Platform/RawScheduler.elm | 6 +++--- 2 files changed, 23 insertions(+), 13 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index c7c91e18..751c3a2a 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -47,6 +47,7 @@ import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) +import Debug @@ -168,7 +169,7 @@ sendToSelf (Router router) msg = -- HELPERS -- -setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never +setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId Never (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = let init = @@ -201,7 +202,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData msg Never) Never, Encode.Value -> List (HiddenMySub msg) -> () ) + -> ( RawScheduler.ProcessId Never (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -316,7 +317,7 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never + -> RawScheduler.ProcessId Never (ReceivedData appMsg selfMsg) setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager sendToAppFunc @@ -330,7 +331,7 @@ instantiateEffectManager : -> RawScheduler.Task state Never -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state Never) -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state Never) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never + -> RawScheduler.ProcessId Never (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let receiver msg state = @@ -351,10 +352,19 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = ) task + channel : RawScheduler.Task (RawScheduler.Channel (ReceivedData appMsg selfMsg)) (ReceivedData appMsg selfMsg) + channel = + RawScheduler.channel () + + selfProcessInitRoot : RawScheduler.Task (state, RawScheduler.Channel Never) (ReceivedData appMsg selfMsg) selfProcessInitRoot = RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) + (\c -> + RawScheduler.andThen + (\() -> RawScheduler.map (\state -> (state, c)) init) + (RawScheduler.sleep 0) + ) + channel selfProcessId = RawScheduler.newProcessId () @@ -365,7 +375,7 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = , selfProcess = selfProcessId } in - RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId + RawScheduler.rawSpawn (\msg _ -> never msg) selfProcessInitRoot selfProcessId unwrapTask : Task Never a -> RawScheduler.Task a Never @@ -438,17 +448,17 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never + , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId Never (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData appMsg Never) Never, Encode.Value -> List (HiddenMySub appMsg) -> () ) + -> ( RawScheduler.ProcessId Never (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never + -> RawScheduler.ProcessId Never (ReceivedData appMsg HiddenSelfMsg) , dispatchEffects : Cmd appMsg -> Sub appMsg diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 83bea293..549e4981 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, Channel, channel, andThen, delay, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) {-| This module contains the low level logic for running tasks and processes. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -59,7 +59,7 @@ type UniqueId = UniqueId UniqueId -andThen : (a -> Task b receive) -> Task a receive -> Task b receive +andThen : (a -> Task b recv2) -> Task a recv -> Task b recv andThen func task = case task of Value val -> @@ -136,7 +136,7 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : (msg -> a -> Task a Never) -> Task a Never -> ProcessId msg Never -> ProcessId msg Never +rawSpawn : (msg -> a -> Task a recv) -> Task a recv -> ProcessId msg recv -> ProcessId msg recv rawSpawn receiver initTask processId = enqueue (registerNewProcess From cc8923c3c3fc9581bdc08f58c74dac38321f3c77 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Mar 2020 20:14:46 +0000 Subject: [PATCH 078/170] Revert "a WIP attempt to use new Tasks in Platform" This reverts commit 770e8bd1c33b701998398e07a977d2ab5f118150. --- src/Platform.elm | 30 ++++++++++-------------------- src/Platform/RawScheduler.elm | 6 +++--- 2 files changed, 13 insertions(+), 23 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 751c3a2a..c7c91e18 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -47,7 +47,6 @@ import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) -import Debug @@ -169,7 +168,7 @@ sendToSelf (Router router) msg = -- HELPERS -- -setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId Never (ReceivedData Never Never) +setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never setupOutgoingPort outgoingPortSend = let init = @@ -202,7 +201,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( RawScheduler.ProcessId Never (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData msg Never) Never, Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -317,7 +316,7 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId Never (ReceivedData appMsg selfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager sendToAppFunc @@ -331,7 +330,7 @@ instantiateEffectManager : -> RawScheduler.Task state Never -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state Never) -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state Never) - -> RawScheduler.ProcessId Never (ReceivedData appMsg selfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let receiver msg state = @@ -352,19 +351,10 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = ) task - channel : RawScheduler.Task (RawScheduler.Channel (ReceivedData appMsg selfMsg)) (ReceivedData appMsg selfMsg) - channel = - RawScheduler.channel () - - selfProcessInitRoot : RawScheduler.Task (state, RawScheduler.Channel Never) (ReceivedData appMsg selfMsg) selfProcessInitRoot = RawScheduler.andThen - (\c -> - RawScheduler.andThen - (\() -> RawScheduler.map (\state -> (state, c)) init) - (RawScheduler.sleep 0) - ) - channel + (\() -> init) + (RawScheduler.sleep 0) selfProcessId = RawScheduler.newProcessId () @@ -375,7 +365,7 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = , selfProcess = selfProcessId } in - RawScheduler.rawSpawn (\msg _ -> never msg) selfProcessInitRoot selfProcessId + RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId unwrapTask : Task Never a -> RawScheduler.Task a Never @@ -448,17 +438,17 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId Never (ReceivedData Never Never) + , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( RawScheduler.ProcessId Never (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData appMsg Never) Never, Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> RawScheduler.ProcessId Never (ReceivedData appMsg HiddenSelfMsg) + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never , dispatchEffects : Cmd appMsg -> Sub appMsg diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 549e4981..83bea293 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, Channel, channel, andThen, delay, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) {-| This module contains the low level logic for running tasks and processes. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -59,7 +59,7 @@ type UniqueId = UniqueId UniqueId -andThen : (a -> Task b recv2) -> Task a recv -> Task b recv +andThen : (a -> Task b receive) -> Task a receive -> Task b receive andThen func task = case task of Value val -> @@ -136,7 +136,7 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : (msg -> a -> Task a recv) -> Task a recv -> ProcessId msg recv -> ProcessId msg recv +rawSpawn : (msg -> a -> Task a Never) -> Task a Never -> ProcessId msg Never -> ProcessId msg Never rawSpawn receiver initTask processId = enqueue (registerNewProcess From 8a3be5b5d55aa96dcb082d2d685dd879646f5d89 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Mar 2020 20:14:49 +0000 Subject: [PATCH 079/170] Revert "sketch for processes receiving values via channels" This reverts commit 842f6bd9eaedc57f6e5b57b6e8a7f6c96a5b913f. --- src/Elm/Kernel/Scheduler.js | 17 ------ src/Platform.elm | 37 ++++++------ src/Platform/RawScheduler.elm | 111 +++++++++------------------------- src/Platform/Scheduler.elm | 10 +-- 4 files changed, 51 insertions(+), 124 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index a7923543..9a1edfe3 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -43,8 +43,6 @@ var _Scheduler_processes = new WeakMap(); var _Scheduler_receivers = new WeakMap(); var _Scheduler_mailboxes = new WeakMap(); -const _Scheduler_processInbox = new WeakMap(); - function _Scheduler_getGuid() { return _Scheduler_guid++; } @@ -116,21 +114,6 @@ const _Scheduler_mailboxReceive = F2((procId, state) => { } }); -const _Scheduler_rawTryRecv = F2((procId, state) => { - const inbox = _Scheduler_processInbox.get(procId); - /**__DEBUG/ - if (inbox === undefined) { - __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); - } - //*/ - const msg = inbox.shift(); - if (msg === undefined) { - return __Maybe_Nothing; - } else { - return __Maybe_Just(inbox); - } -}); - var _Scheduler_working = false; var _Scheduler_queue = []; diff --git a/src/Platform.elm b/src/Platform.elm index c7c91e18..0c14453b 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -49,7 +49,6 @@ import String exposing (String) - -- PROGRAMS @@ -119,7 +118,7 @@ information on this. It is only defined here because it is a platform primitive. -} type Task err ok - = Task (RawScheduler.Task (Result err ok) Never) + = Task (RawScheduler.Task (Result err ok)) {-| Head over to the documentation for the [`Process`](Process) module for @@ -127,7 +126,7 @@ information on this. It is only defined here because it is a platform primitive. -} type ProcessId - = ProcessId (RawScheduler.ProcessId Never Never) + = ProcessId (RawScheduler.ProcessId Never) @@ -140,7 +139,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp : appMsg -> () - , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never + , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) } @@ -168,7 +167,7 @@ sendToSelf (Router router) msg = -- HELPERS -- -setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never +setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = let init = @@ -182,7 +181,7 @@ setupOutgoingPort outgoingPortSend = -> List (HiddenMyCmd Never) -> List (HiddenMySub Never) -> () - -> RawScheduler.Task () Never + -> RawScheduler.Task () onEffects _ cmdList _ () = RawScheduler.execImpure (\() -> @@ -201,7 +200,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData msg Never) Never, Encode.Value -> List (HiddenMySub msg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -230,7 +229,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () dispatchEffects cmdBag subBag = let @@ -316,7 +315,7 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager sendToAppFunc @@ -327,10 +326,10 @@ setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager : SendToApp appMsg - -> RawScheduler.Task state Never - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state Never) - -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state Never) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) Never + -> RawScheduler.Task state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state) + -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state) + -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let receiver msg state = @@ -368,7 +367,7 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId -unwrapTask : Task Never a -> RawScheduler.Task a Never +unwrapTask : Task Never a -> RawScheduler.Task a unwrapTask (Task task) = RawScheduler.map (\res -> @@ -401,7 +400,7 @@ type UpdateMetadata type OtherManagers appMsg - = OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never)) + = OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) type ReceivedData appMsg selfMsg @@ -438,22 +437,22 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) Never + , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData appMsg Never) Never, Encode.Value -> List (HiddenMySub appMsg) -> () ) + -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) Never + -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) -> () } diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 83bea293..48ef6768 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -26,40 +26,34 @@ import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) -type Task val receive +type Task val = Value val - | AsyncAction (DoneCallback val receive -> TryAbortAction) - | SyncAction (() -> Task val receive) - | Receive (receive -> Task val receive) - | TryReceive (Maybe receive -> Task val receive) + | AsyncAction (DoneCallback val -> TryAbortAction) + | SyncAction (() -> Task val) -type alias DoneCallback val receive = - Task val receive -> () +type alias DoneCallback val = + Task val -> () type alias TryAbortAction = () -> () -type ProcessState receive state - = Ready (Task state receive) +type ProcessState msg state + = Ready (Task state) | Running TryAbortAction -type ProcessId msg recv +type ProcessId msg = ProcessId { id : UniqueId } -type Channel receive - = Channel - - type UniqueId = UniqueId UniqueId -andThen : (a -> Task b receive) -> Task a receive -> Task b receive +andThen : (a -> Task b) -> Task a -> Task b andThen func task = case task of Value val -> @@ -75,43 +69,16 @@ andThen func task = (\newTask -> doneCallback (andThen func newTask)) ) - Receive receiver -> - Receive - (\message -> - andThen func (receiver message) - ) - - TryReceive receiver -> - TryReceive - (\message -> - andThen func (receiver message) - ) - - -channel : () -> Task (Channel receive) receive -channel () = - Value Channel - - -recv : (receive -> a) -> Channel receive -> Task a receive -recv fn chl = - Receive (\r -> Value (fn r)) - - -tryRecv : (Maybe receive -> a) -> Channel receive -> Task a receive -tryRecv fn chl = - TryReceive (\r -> Value (fn r)) - {-| Create a task that executes a non pure function -} -execImpure : (() -> a) -> Task a receive +execImpure : (() -> a) -> Task a execImpure func = SyncAction (\() -> Value (func ())) -map : (a -> b) -> Task a receive -> Task b receive +map : (a -> b) -> Task a -> Task b map func = andThen (\x -> Value (func x)) @@ -126,7 +93,7 @@ this process before it has been registered will give a **runtime** error. (It may even fail silently in optimized compiles.) -} -newProcessId : () -> ProcessId msg recv +newProcessId : () -> ProcessId msg newProcessId () = ProcessId { id = getGuid () } @@ -136,7 +103,7 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : (msg -> a -> Task a Never) -> Task a Never -> ProcessId msg Never -> ProcessId msg Never +rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg rawSpawn receiver initTask processId = enqueue (registerNewProcess @@ -155,7 +122,7 @@ If the process is "ready" it will then act upon the next message in its mailbox. -} -rawSend : ProcessId msg Never -> msg -> ProcessId msg Never +rawSend : ProcessId msg -> msg -> ProcessId msg rawSend processId msg = let _ = @@ -166,7 +133,7 @@ rawSend processId msg = {-| Create a task, if run, will make the process deal with a message. -} -send : ProcessId msg Never -> msg -> Task () receive +send : ProcessId msg -> msg -> Task () send processId msg = SyncAction (\() -> @@ -180,7 +147,7 @@ send processId msg = {-| Create a task that spawns a processes. -} -spawn : (msg -> a -> Task a Never) -> Task a Never -> Task (ProcessId msg Never) Never +spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) spawn receiver task = SyncAction (\() -> Value (rawSpawn receiver task (newProcessId ()))) @@ -188,7 +155,7 @@ spawn receiver task = {-| Create a task that sleeps for `time` milliseconds -} -sleep : Float -> Task () receive +sleep : Float -> Task () sleep time = AsyncAction (delay time (Value ())) @@ -197,11 +164,11 @@ sleep time = To kill a process we should try to abort any ongoing async action. We only allow processes that cannot receive messages to be killed, we will -allow the offical core library to lead the way regarding processes that can +on the offical core library to lead the way regarding processes that can receive values. -} -kill : ProcessId Never Never -> Task () receive +kill : ProcessId Never -> Task () kill processId = SyncAction (\() -> @@ -225,7 +192,7 @@ call, drain the run queue but stepping all processes. Returns the enqueued `Process`. -} -enqueue : ProcessId msg recv -> ProcessId msg recv +enqueue : ProcessId msg -> ProcessId msg enqueue id = enqueueWithStepper (\procId -> @@ -264,7 +231,7 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId msg receive -> (Task state receive -> ()) -> ProcessState receive state -> ProcessState receive state +stepper : ProcessId msg -> (Task state -> ()) -> ProcessState msg state -> ProcessState msg state stepper processId onAsyncActionDone process = case process of Running _ -> @@ -290,23 +257,6 @@ stepper processId onAsyncActionDone process = onAsyncActionDone (Ready (doEffect ())) - Ready (Receive receiver) -> - case rawTryRecv processId of - Just received -> - stepper - processId - onAsyncActionDone - (Ready (receiver received)) - - Nothing -> - process - - Ready (TryReceive receiver) -> - stepper - processId - onAsyncActionDone - (Ready (receiver (rawTryRecv processId))) - -- Kernel function redefinitons -- @@ -317,42 +267,37 @@ getGuid = Elm.Kernel.Scheduler.getGuid -updateProcessState : (ProcessState recv state -> ProcessState recv state) -> ProcessId msg recv -> ProcessState recv state +updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state updateProcessState = Elm.Kernel.Scheduler.updateProcessState -mailboxAdd : msg -> ProcessId msg Never -> msg +mailboxAdd : msg -> ProcessId msg -> msg mailboxAdd = Elm.Kernel.Scheduler.mailboxAdd -mailboxReceive : ProcessId msg recv -> state -> Maybe (Task state recv) +mailboxReceive : ProcessId msg -> state -> Maybe (Task state) mailboxReceive = Elm.Kernel.Scheduler.mailboxReceive -rawTryRecv : ProcessId msg receive -> Maybe receive -rawTryRecv = - Elm.Kernel.Scheduler.rawTryRecv - - -getProcessState : ProcessId msg recv -> ProcessState recv state +getProcessState : ProcessId msg -> ProcessState msg state getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg recv -> (msg -> state -> Task state recv) -> ProcessState receive state -> ProcessId msg recv +registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess -enqueueWithStepper : (ProcessId msg recv -> ()) -> ProcessId msg recv -> ProcessId msg recv +enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper -delay : Float -> Task val receive -> DoneCallback val receive -> TryAbortAction +delay : Float -> Task val -> DoneCallback val -> TryAbortAction delay = Elm.Kernel.Scheduler.delay diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 829efcd7..b4e15dfa 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -51,7 +51,7 @@ import Result exposing (Result(..)) type alias ProcessId msg = - RawScheduler.ProcessId msg Never + RawScheduler.ProcessId msg type alias DoneCallback err ok = @@ -172,22 +172,22 @@ sleep time = -- wrapping helpers -- -wrapTaskFn : (RawScheduler.Task (Result e1 o1) Never -> RawScheduler.Task (Result e2 o2) Never) -> Platform.Task e1 o1 -> Platform.Task e2 o2 +wrapTaskFn : (RawScheduler.Task (Result e1 o1) -> RawScheduler.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 wrapTaskFn fn task = wrapTask (taskFn fn task) -taskFn : (RawScheduler.Task (Result e1 o1) Never -> a) -> Platform.Task e1 o1 -> a +taskFn : (RawScheduler.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a taskFn fn task = fn (unwrapTask task) -wrapTask : RawScheduler.Task (Result e o) Never -> Platform.Task e o +wrapTask : RawScheduler.Task (Result e o) -> Platform.Task e o wrapTask = Elm.Kernel.Platform.wrapTask -unwrapTask : Platform.Task e o -> RawScheduler.Task (Result e o) Never +unwrapTask : Platform.Task e o -> RawScheduler.Task (Result e o) unwrapTask = Elm.Kernel.Basics.unwrapTypeWrapper From ebe27078d0d2f0784b9f47319eb8d29305b02b8d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Mar 2020 22:13:04 +0000 Subject: [PATCH 080/170] WIP channel api --- src/Elm/Kernel/Scheduler.js | 97 +++++++++++++++++++++++------------ src/Platform.elm | 51 ++++++++++-------- src/Platform/Channel.elm | 71 +++++++++++++++++++++++++ src/Platform/RawScheduler.elm | 58 +++++---------------- src/Platform/Scheduler.elm | 3 +- 5 files changed, 181 insertions(+), 99 deletions(-) create mode 100644 src/Platform/Channel.elm diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 9a1edfe3..53668e07 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -40,8 +40,6 @@ function _Scheduler_rawSpawn(task) var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); -var _Scheduler_receivers = new WeakMap(); -var _Scheduler_mailboxes = new WeakMap(); function _Scheduler_getGuid() { return _Scheduler_guid++; @@ -74,45 +72,43 @@ var _Scheduler_updateProcessState = F2((func, id) => { return procState; }); -var _Scheduler_registerNewProcess = F3((procId, receiver, procState) => { +var _Scheduler_registerNewProcess = F3((procId, procState) => { /**__DEBUG/ - if (procState === undefined) { + if (_Scheduler_processes.has(procId)) { __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); } //*/ _Scheduler_processes.set(procId, procState); - _Scheduler_receivers.set(procId, receiver); - _Scheduler_mailboxes.set(procId, []); return procId; }); -var _Scheduler_mailboxAdd = F2((message, procId) => { - const mailbox = _Scheduler_mailboxes.get(procId); - /**__DEBUG/ - if (mailbox === undefined) { - __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); - } - //*/ - mailbox.push(message); - return procId; -}); - -const _Scheduler_mailboxReceive = F2((procId, state) => { - const receiver = _Scheduler_receivers.get(procId); - const mailbox = _Scheduler_mailboxes.get(procId); - /**__DEBUG/ - if (receiver === undefined || mailbox === undefined) { - __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); - } - //*/ - const msg = mailbox.shift(); - if (msg === undefined) { - return __Maybe_Nothing; - } else { - return __Maybe_Just(A2(receiver, msg, state)); - } -}); +// var _Scheduler_mailboxAdd = F2((message, procId) => { +// const mailbox = _Scheduler_mailboxes.get(procId); +// /**__DEBUG/ +// if (mailbox === undefined) { +// __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); +// } +// //*/ +// mailbox.push(message); +// return procId; +// }); + +// const _Scheduler_mailboxReceive = F2((procId, state) => { +// const receiver = _Scheduler_receivers.get(procId); +// const mailbox = _Scheduler_mailboxes.get(procId); +// /**__DEBUG/ +// if (receiver === undefined || mailbox === undefined) { +// __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); +// } +// //*/ +// const msg = mailbox.shift(); +// if (msg === undefined) { +// return __Maybe_Nothing; +// } else { +// return __Maybe_Just(A2(receiver, msg, state)); +// } +// }); var _Scheduler_working = false; var _Scheduler_queue = []; @@ -151,3 +147,40 @@ const _Scheduler_runOnNextTick = F2((callback, val) => { Promise.resolve(val).then(callback); return _Utils_Tuple0; }); + + +// CHANNELS + +const _Scheduler_channels = new WeakMap(); +const _Scheduler_wakers = new WeakMap(); + +const _Scheduler_rawRecv = F3((channelId, tryAbortAction, doneCallback) => { + const channel = _Scheduler_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + const msg = channel.shift(); + if (msg === undefined) { + const waker = _Scheduler_wakers.get(channelId); + /**__DEBUG/ + if (waker === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + const onWake = msg => doneCallback(msg); + waker.add(onWake); + return x => { + waker.delete(onWake); + return x; + }; + } else { + doneCallback(msg); + return _ => { + /**__DEBUG/ + __Debug_crash(12, 'abortCompletedAsyncAction'); + //*/ + }; + } +}); diff --git a/src/Platform.elm b/src/Platform.elm index 0c14453b..433238f9 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -43,6 +43,7 @@ import Maybe exposing (Maybe(..)) import Platform.Bag as Bag import Platform.Cmd exposing (Cmd) import Platform.RawScheduler as RawScheduler +import Platform.Channel as Channel import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) @@ -140,6 +141,7 @@ type Router appMsg selfMsg = Router { sendToApp : appMsg -> () , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + , channel : Channel.Channel (ReceivedData appMsg selfMsg) } @@ -332,39 +334,48 @@ instantiateEffectManager : -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let - receiver msg state = + receiveMsg : + Channel.Channel (ReceivedData appMsg selfMsg) + -> state + -> (ReceivedData appMsg selfMsg) + -> RawScheduler.Task state + receiveMsg channel state msg = let + task : RawScheduler.Task state task = case msg of Self value -> - onSelfMsg router value state + onSelfMsg (Router router) value state App cmds subs -> - onEffects router cmds subs state + onEffects (Router router) cmds subs state in - RawScheduler.andThen - (\val -> - RawScheduler.map - (\() -> val) - (RawScheduler.sleep 0) - ) - task - - selfProcessInitRoot = - RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) + task + |> RawScheduler.andThen + (\val -> + RawScheduler.map + (\() -> val) + (RawScheduler.sleep 0) + ) + |> RawScheduler.andThen (\newState -> Channel.recv (receiveMsg channel newState) channel) + + + initTask : RawScheduler.Task state + initTask = + RawScheduler.sleep 0 + |> RawScheduler.andThen (\_ -> init) + |> RawScheduler.andThen (\state -> Channel.recv (receiveMsg router.channel state) router.channel) selfProcessId = RawScheduler.newProcessId () router = - Router - { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfProcess = selfProcessId - } + { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate + , selfProcess = selfProcessId + , channel = Channel.channel () + } in - RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId + RawScheduler.rawSpawn initTask selfProcessId unwrapTask : Task Never a -> RawScheduler.Task a diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm new file mode 100644 index 00000000..57ec2f9f --- /dev/null +++ b/src/Platform/Channel.elm @@ -0,0 +1,71 @@ +module Platform.Channel exposing (recv, Channel, channel, rawSend, send) + + +import Basics exposing (..) +import Elm.Kernel.Scheduler +import Maybe exposing (Maybe(..)) +import Debug + +import Platform.RawScheduler as RawScheduler + + +type Channel msg + = Channel {} + + +{-| +-} +recv : (msg -> RawScheduler.Task a) -> Channel msg -> RawScheduler.Task a +recv tagger chl = + let + innerDoneCallback : RawScheduler.DoneCallback a -> RawScheduler.Task msg -> () + innerDoneCallback doneCallback newTask = + doneCallback (RawScheduler.andThen (\msg -> tagger msg) newTask) + in + + RawScheduler.AsyncAction + (\doneCallback -> + rawRecv + chl + (innerDoneCallback doneCallback) + ) + + +{-| NON PURE! + +Send a message to a process (adds the message to the processes mailbox) and +**enqueue** that process. + +If the process is "ready" it will then act upon the next message in its +mailbox. + +-} +rawSend : Channel msg -> () +rawSend channelId = + let + _ = + mailboxAdd msg processId + in + enqueue processId + + +{-| Create a task, if run, will make the process deal with a message. +-} +send : ProcessId msg -> msg -> Task () +send processId msg = + SyncAction + (\() -> + let + (ProcessId _) = + rawSend processId msg + in + Value () + ) + +channel : () -> Channel msg +channel () = + Channel {} + +rawRecv : Channel msg -> RawScheduler.DoneCallback msg -> RawScheduler.TryAbortAction +rawRecv = + Elm.Kernel.Scheduler.rawRecv diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 48ef6768..a20b1062 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -24,6 +24,7 @@ nicer API. `Platform` cannot import `Platform.Scheduler` as import Basics exposing (..) import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) +import Debug type Task val @@ -103,54 +104,21 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg -rawSpawn receiver initTask processId = +rawSpawn : Task a -> ProcessId msg -> ProcessId msg +rawSpawn initTask processId = enqueue (registerNewProcess processId - receiver (Ready initTask) ) -{-| NON PURE! - -Send a message to a process (adds the message to the processes mailbox) and -**enqueue** that process. - -If the process is "ready" it will then act upon the next message in its -mailbox. - --} -rawSend : ProcessId msg -> msg -> ProcessId msg -rawSend processId msg = - let - _ = - mailboxAdd msg processId - in - enqueue processId - - -{-| Create a task, if run, will make the process deal with a message. --} -send : ProcessId msg -> msg -> Task () -send processId msg = - SyncAction - (\() -> - let - (ProcessId _) = - rawSend processId msg - in - Value () - ) - - {-| Create a task that spawns a processes. -} -spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) -spawn receiver task = +spawn : Task a -> Task (ProcessId msg) +spawn task = SyncAction - (\() -> Value (rawSpawn receiver task (newProcessId ()))) + (\() -> Value (rawSpawn task (newProcessId ()))) {-| Create a task that sleeps for `time` milliseconds @@ -272,14 +240,14 @@ updateProcessState = Elm.Kernel.Scheduler.updateProcessState -mailboxAdd : msg -> ProcessId msg -> msg -mailboxAdd = - Elm.Kernel.Scheduler.mailboxAdd +-- mailboxAdd : msg -> ProcessId msg -> msg +-- mailboxAdd = +-- Elm.Kernel.Scheduler.mailboxAdd -mailboxReceive : ProcessId msg -> state -> Maybe (Task state) -mailboxReceive = - Elm.Kernel.Scheduler.mailboxReceive +-- mailboxReceive : ProcessId msg -> state -> Maybe (Task state) +-- mailboxReceive = +-- Elm.Kernel.Scheduler.mailboxReceive getProcessState : ProcessId msg -> ProcessState msg state @@ -287,7 +255,7 @@ getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg +registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index b4e15dfa..824363f7 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -132,7 +132,7 @@ spawn = (\task -> RawScheduler.map (\proc -> Ok (wrapProcessId proc)) - (RawScheduler.spawn (\msg _ -> never msg) task) + (RawScheduler.spawn task) ) @@ -147,7 +147,6 @@ rawSpawn = (\task -> wrapProcessId (RawScheduler.rawSpawn - (\msg _ -> never msg) task (RawScheduler.newProcessId ()) ) From 1f9069a05f9958ab88abf9a399f5a069af2e555f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 17 Mar 2020 22:27:00 +0000 Subject: [PATCH 081/170] Revert "WIP channel api" This reverts commit ebe27078d0d2f0784b9f47319eb8d29305b02b8d. --- src/Elm/Kernel/Scheduler.js | 97 ++++++++++++----------------------- src/Platform.elm | 51 ++++++++---------- src/Platform/Channel.elm | 71 ------------------------- src/Platform/RawScheduler.elm | 58 ++++++++++++++++----- src/Platform/Scheduler.elm | 3 +- 5 files changed, 99 insertions(+), 181 deletions(-) delete mode 100644 src/Platform/Channel.elm diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 53668e07..9a1edfe3 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -40,6 +40,8 @@ function _Scheduler_rawSpawn(task) var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); +var _Scheduler_receivers = new WeakMap(); +var _Scheduler_mailboxes = new WeakMap(); function _Scheduler_getGuid() { return _Scheduler_guid++; @@ -72,43 +74,45 @@ var _Scheduler_updateProcessState = F2((func, id) => { return procState; }); -var _Scheduler_registerNewProcess = F3((procId, procState) => { +var _Scheduler_registerNewProcess = F3((procId, receiver, procState) => { /**__DEBUG/ - if (_Scheduler_processes.has(procId)) { + if (procState === undefined) { __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); } //*/ _Scheduler_processes.set(procId, procState); + _Scheduler_receivers.set(procId, receiver); + _Scheduler_mailboxes.set(procId, []); return procId; }); -// var _Scheduler_mailboxAdd = F2((message, procId) => { -// const mailbox = _Scheduler_mailboxes.get(procId); -// /**__DEBUG/ -// if (mailbox === undefined) { -// __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); -// } -// //*/ -// mailbox.push(message); -// return procId; -// }); - -// const _Scheduler_mailboxReceive = F2((procId, state) => { -// const receiver = _Scheduler_receivers.get(procId); -// const mailbox = _Scheduler_mailboxes.get(procId); -// /**__DEBUG/ -// if (receiver === undefined || mailbox === undefined) { -// __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); -// } -// //*/ -// const msg = mailbox.shift(); -// if (msg === undefined) { -// return __Maybe_Nothing; -// } else { -// return __Maybe_Just(A2(receiver, msg, state)); -// } -// }); +var _Scheduler_mailboxAdd = F2((message, procId) => { + const mailbox = _Scheduler_mailboxes.get(procId); + /**__DEBUG/ + if (mailbox === undefined) { + __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); + } + //*/ + mailbox.push(message); + return procId; +}); + +const _Scheduler_mailboxReceive = F2((procId, state) => { + const receiver = _Scheduler_receivers.get(procId); + const mailbox = _Scheduler_mailboxes.get(procId); + /**__DEBUG/ + if (receiver === undefined || mailbox === undefined) { + __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); + } + //*/ + const msg = mailbox.shift(); + if (msg === undefined) { + return __Maybe_Nothing; + } else { + return __Maybe_Just(A2(receiver, msg, state)); + } +}); var _Scheduler_working = false; var _Scheduler_queue = []; @@ -147,40 +151,3 @@ const _Scheduler_runOnNextTick = F2((callback, val) => { Promise.resolve(val).then(callback); return _Utils_Tuple0; }); - - -// CHANNELS - -const _Scheduler_channels = new WeakMap(); -const _Scheduler_wakers = new WeakMap(); - -const _Scheduler_rawRecv = F3((channelId, tryAbortAction, doneCallback) => { - const channel = _Scheduler_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); - } - //*/ - const msg = channel.shift(); - if (msg === undefined) { - const waker = _Scheduler_wakers.get(channelId); - /**__DEBUG/ - if (waker === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); - } - //*/ - const onWake = msg => doneCallback(msg); - waker.add(onWake); - return x => { - waker.delete(onWake); - return x; - }; - } else { - doneCallback(msg); - return _ => { - /**__DEBUG/ - __Debug_crash(12, 'abortCompletedAsyncAction'); - //*/ - }; - } -}); diff --git a/src/Platform.elm b/src/Platform.elm index 433238f9..0c14453b 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -43,7 +43,6 @@ import Maybe exposing (Maybe(..)) import Platform.Bag as Bag import Platform.Cmd exposing (Cmd) import Platform.RawScheduler as RawScheduler -import Platform.Channel as Channel import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) @@ -141,7 +140,6 @@ type Router appMsg selfMsg = Router { sendToApp : appMsg -> () , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) - , channel : Channel.Channel (ReceivedData appMsg selfMsg) } @@ -334,48 +332,39 @@ instantiateEffectManager : -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let - receiveMsg : - Channel.Channel (ReceivedData appMsg selfMsg) - -> state - -> (ReceivedData appMsg selfMsg) - -> RawScheduler.Task state - receiveMsg channel state msg = + receiver msg state = let - task : RawScheduler.Task state task = case msg of Self value -> - onSelfMsg (Router router) value state + onSelfMsg router value state App cmds subs -> - onEffects (Router router) cmds subs state + onEffects router cmds subs state in - task - |> RawScheduler.andThen - (\val -> - RawScheduler.map - (\() -> val) - (RawScheduler.sleep 0) - ) - |> RawScheduler.andThen (\newState -> Channel.recv (receiveMsg channel newState) channel) - - - initTask : RawScheduler.Task state - initTask = - RawScheduler.sleep 0 - |> RawScheduler.andThen (\_ -> init) - |> RawScheduler.andThen (\state -> Channel.recv (receiveMsg router.channel state) router.channel) + RawScheduler.andThen + (\val -> + RawScheduler.map + (\() -> val) + (RawScheduler.sleep 0) + ) + task + + selfProcessInitRoot = + RawScheduler.andThen + (\() -> init) + (RawScheduler.sleep 0) selfProcessId = RawScheduler.newProcessId () router = - { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfProcess = selfProcessId - , channel = Channel.channel () - } + Router + { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate + , selfProcess = selfProcessId + } in - RawScheduler.rawSpawn initTask selfProcessId + RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId unwrapTask : Task Never a -> RawScheduler.Task a diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm deleted file mode 100644 index 57ec2f9f..00000000 --- a/src/Platform/Channel.elm +++ /dev/null @@ -1,71 +0,0 @@ -module Platform.Channel exposing (recv, Channel, channel, rawSend, send) - - -import Basics exposing (..) -import Elm.Kernel.Scheduler -import Maybe exposing (Maybe(..)) -import Debug - -import Platform.RawScheduler as RawScheduler - - -type Channel msg - = Channel {} - - -{-| --} -recv : (msg -> RawScheduler.Task a) -> Channel msg -> RawScheduler.Task a -recv tagger chl = - let - innerDoneCallback : RawScheduler.DoneCallback a -> RawScheduler.Task msg -> () - innerDoneCallback doneCallback newTask = - doneCallback (RawScheduler.andThen (\msg -> tagger msg) newTask) - in - - RawScheduler.AsyncAction - (\doneCallback -> - rawRecv - chl - (innerDoneCallback doneCallback) - ) - - -{-| NON PURE! - -Send a message to a process (adds the message to the processes mailbox) and -**enqueue** that process. - -If the process is "ready" it will then act upon the next message in its -mailbox. - --} -rawSend : Channel msg -> () -rawSend channelId = - let - _ = - mailboxAdd msg processId - in - enqueue processId - - -{-| Create a task, if run, will make the process deal with a message. --} -send : ProcessId msg -> msg -> Task () -send processId msg = - SyncAction - (\() -> - let - (ProcessId _) = - rawSend processId msg - in - Value () - ) - -channel : () -> Channel msg -channel () = - Channel {} - -rawRecv : Channel msg -> RawScheduler.DoneCallback msg -> RawScheduler.TryAbortAction -rawRecv = - Elm.Kernel.Scheduler.rawRecv diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index a20b1062..48ef6768 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -24,7 +24,6 @@ nicer API. `Platform` cannot import `Platform.Scheduler` as import Basics exposing (..) import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) -import Debug type Task val @@ -104,21 +103,54 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : Task a -> ProcessId msg -> ProcessId msg -rawSpawn initTask processId = +rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg +rawSpawn receiver initTask processId = enqueue (registerNewProcess processId + receiver (Ready initTask) ) +{-| NON PURE! + +Send a message to a process (adds the message to the processes mailbox) and +**enqueue** that process. + +If the process is "ready" it will then act upon the next message in its +mailbox. + +-} +rawSend : ProcessId msg -> msg -> ProcessId msg +rawSend processId msg = + let + _ = + mailboxAdd msg processId + in + enqueue processId + + +{-| Create a task, if run, will make the process deal with a message. +-} +send : ProcessId msg -> msg -> Task () +send processId msg = + SyncAction + (\() -> + let + (ProcessId _) = + rawSend processId msg + in + Value () + ) + + {-| Create a task that spawns a processes. -} -spawn : Task a -> Task (ProcessId msg) -spawn task = +spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) +spawn receiver task = SyncAction - (\() -> Value (rawSpawn task (newProcessId ()))) + (\() -> Value (rawSpawn receiver task (newProcessId ()))) {-| Create a task that sleeps for `time` milliseconds @@ -240,14 +272,14 @@ updateProcessState = Elm.Kernel.Scheduler.updateProcessState --- mailboxAdd : msg -> ProcessId msg -> msg --- mailboxAdd = --- Elm.Kernel.Scheduler.mailboxAdd +mailboxAdd : msg -> ProcessId msg -> msg +mailboxAdd = + Elm.Kernel.Scheduler.mailboxAdd --- mailboxReceive : ProcessId msg -> state -> Maybe (Task state) --- mailboxReceive = --- Elm.Kernel.Scheduler.mailboxReceive +mailboxReceive : ProcessId msg -> state -> Maybe (Task state) +mailboxReceive = + Elm.Kernel.Scheduler.mailboxReceive getProcessState : ProcessId msg -> ProcessState msg state @@ -255,7 +287,7 @@ getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg +registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 824363f7..b4e15dfa 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -132,7 +132,7 @@ spawn = (\task -> RawScheduler.map (\proc -> Ok (wrapProcessId proc)) - (RawScheduler.spawn task) + (RawScheduler.spawn (\msg _ -> never msg) task) ) @@ -147,6 +147,7 @@ rawSpawn = (\task -> wrapProcessId (RawScheduler.rawSpawn + (\msg _ -> never msg) task (RawScheduler.newProcessId ()) ) From fb084988679f80233b08f0715939709fea9a8c05 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 18 Mar 2020 23:29:54 +0000 Subject: [PATCH 082/170] remove next tick hack --- src/Elm/Kernel/Scheduler.js | 25 ++++++++-- src/Platform/RawScheduler.elm | 92 +++++++++++++++++------------------ 2 files changed, 67 insertions(+), 50 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 9a1edfe3..6489b71c 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -40,6 +40,7 @@ function _Scheduler_rawSpawn(task) var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); +var _Scheduler_readyFlgs = new WeakMap(); var _Scheduler_receivers = new WeakMap(); var _Scheduler_mailboxes = new WeakMap(); @@ -66,12 +67,12 @@ var _Scheduler_updateProcessState = F2((func, id) => { //*/ const updatedState = func(procState); /**__DEBUG/ - if (procState !== _Scheduler_processes.get(id)) { + if (procState !== _Scheduler_processes.get(id)) { __Debug_crash(12, 'reentrantProcUpdate', id && id.a && id.a.__$id); } //*/ _Scheduler_processes.set(id, updatedState); - return procState; + return _Utils_Tuple0; }); var _Scheduler_registerNewProcess = F3((procId, receiver, procState) => { @@ -147,7 +148,23 @@ var _Scheduler_delay = F3(function (time, value, callback) }); -const _Scheduler_runOnNextTick = F2((callback, val) => { - Promise.resolve(val).then(callback); +const _Scheduler_getWokenValue = procId => { + const flag = _Scheduler_readyFlgs.get(procId); + if (flag === undefined) { + return __Maybe_Nothing; + } else { + _Scheduler_readyFlgs.delete(procId); + return __Maybe_Just(flag); + } +}; + + +const _Scheduler_setWakeTask = F2((procId, newRoot) => { + /**__DEBUG/ + if (_Scheduler_readyFlgs.has(procId)) { + __Debug_crash(12, 'procIdAlreadyReady', procId && procId.a && procId.a.__$id); + } + //*/ + _Scheduler_readyFlgs.set(procId, newRoot); return _Utils_Tuple0; }); diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 48ef6768..40d63e49 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, delay, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) {-| This module contains the low level logic for running tasks and processes. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -195,29 +195,7 @@ Returns the enqueued `Process`. enqueue : ProcessId msg -> ProcessId msg enqueue id = enqueueWithStepper - (\procId -> - let - onAsyncActionDone = - runOnNextTick - (\newRoot -> - let - _ = - updateProcessState - (\_ -> Ready newRoot) - procId - in - let - (ProcessId _) = - enqueue procId - in - () - ) - - _ = - updateProcessState (stepper procId onAsyncActionDone) procId - in - () - ) + (\procId -> updateProcessState (stepper procId) procId) id @@ -231,33 +209,50 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId msg -> (Task state -> ()) -> ProcessState msg state -> ProcessState msg state -stepper processId onAsyncActionDone process = +stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state +stepper processId process = case process of Running _ -> - process - - Ready (Value val) -> - case mailboxReceive processId val of - Just newRoot -> - stepper - processId - onAsyncActionDone - (Ready newRoot) + case getWokenValue processId of + Just root -> + createStateWithRoot processId root Nothing -> process - Ready (AsyncAction doEffect) -> - Running (doEffect onAsyncActionDone) + Ready root -> + createStateWithRoot processId root + - Ready (SyncAction doEffect) -> - stepper - processId - onAsyncActionDone - (Ready (doEffect ())) +createStateWithRoot : ProcessId msg -> Task state -> ProcessState msg state +createStateWithRoot processId root = + case root of + Value val -> + case mailboxReceive processId val of + Just newRoot -> + createStateWithRoot processId newRoot + Nothing -> + Ready (Value val) + AsyncAction doEffect -> + Running + (doEffect + (\newRoot -> + let + () = + setWakeTask processId newRoot + in + let + (ProcessId _) = + enqueue processId + in + () + ) + ) + + SyncAction doEffect -> + createStateWithRoot processId (doEffect ()) -- Kernel function redefinitons -- @@ -267,7 +262,7 @@ getGuid = Elm.Kernel.Scheduler.getGuid -updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessState msg state +updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> () updateProcessState = Elm.Kernel.Scheduler.updateProcessState @@ -302,6 +297,11 @@ delay = Elm.Kernel.Scheduler.delay -runOnNextTick : (a -> ()) -> a -> () -runOnNextTick = - Elm.Kernel.Scheduler.runOnNextTick +getWokenValue : ProcessId msg -> Maybe (Task state) +getWokenValue = + Elm.Kernel.Scheduler.getWokenValue + + +setWakeTask : ProcessId msg -> Task state -> () +setWakeTask = + Elm.Kernel.Scheduler.setWakeTask From bce17331e8534352d07c6ecb943ed6b1998b9b92 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 18 Mar 2020 23:35:12 +0000 Subject: [PATCH 083/170] remove sync action --- src/Platform.elm | 2 +- src/Platform/RawScheduler.elm | 40 ++++++++++++++++------------------- 2 files changed, 19 insertions(+), 23 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 0c14453b..64493236 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -148,7 +148,7 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Task (RawScheduler.SyncAction (\() -> RawScheduler.Value (Ok (router.sendToApp msg)))) + Task (RawScheduler.execImpure (\() -> Ok (router.sendToApp msg))) {-| Send the router a message for your effect manager. This message will diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 40d63e49..ffbb4018 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -29,7 +29,6 @@ import Maybe exposing (Maybe(..)) type Task val = Value val | AsyncAction (DoneCallback val -> TryAbortAction) - | SyncAction (() -> Task val) type alias DoneCallback val = @@ -59,9 +58,6 @@ andThen func task = Value val -> func val - SyncAction thunk -> - SyncAction (\() -> andThen func (thunk ())) - AsyncAction doEffect -> AsyncAction (\doneCallback -> @@ -74,8 +70,14 @@ andThen func task = -} execImpure : (() -> a) -> Task a execImpure func = - SyncAction - (\() -> Value (func ())) + AsyncAction + (\doneCallback -> + let + () = + doneCallback (Value (func ())) + in + \() -> () + ) map : (a -> b) -> Task a -> Task b @@ -135,13 +137,13 @@ rawSend processId msg = -} send : ProcessId msg -> msg -> Task () send processId msg = - SyncAction + execImpure (\() -> let (ProcessId _) = rawSend processId msg in - Value () + () ) @@ -149,8 +151,7 @@ send processId msg = -} spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) spawn receiver task = - SyncAction - (\() -> Value (rawSpawn receiver task (newProcessId ()))) + execImpure (\() -> rawSpawn receiver task (newProcessId ())) {-| Create a task that sleeps for `time` milliseconds @@ -170,18 +171,14 @@ receive values. -} kill : ProcessId Never -> Task () kill processId = - SyncAction + execImpure (\() -> - let - () = - case getProcessState processId of - Running killer -> - killer () + case getProcessState processId of + Running killer -> + killer () - Ready _ -> - () - in - Value () + Ready _ -> + () ) @@ -251,8 +248,7 @@ createStateWithRoot processId root = ) ) - SyncAction doEffect -> - createStateWithRoot processId (doEffect ()) + -- Kernel function redefinitons -- From 846dc4da182a6508236790ac1044a55f2af7c572 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 19 Mar 2020 23:05:24 +0000 Subject: [PATCH 084/170] new channel api Still a WIP, I think this is solid though and with a bit more iteration could lay the groundwork for elm standard libraries without effect modules. --- src/Elm/Kernel/Scheduler.js | 86 ++++++++++++++++++++++------------- src/Platform.elm | 79 ++++++++++++++++++-------------- src/Platform/Channel.elm | 59 ++++++++++++++++++++++++ src/Platform/RawScheduler.elm | 73 ++++++----------------------- src/Platform/Scheduler.elm | 12 +---- 5 files changed, 175 insertions(+), 134 deletions(-) create mode 100644 src/Platform/Channel.elm diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 6489b71c..18fafdba 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -41,8 +41,6 @@ function _Scheduler_rawSpawn(task) var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); var _Scheduler_readyFlgs = new WeakMap(); -var _Scheduler_receivers = new WeakMap(); -var _Scheduler_mailboxes = new WeakMap(); function _Scheduler_getGuid() { return _Scheduler_guid++; @@ -75,45 +73,17 @@ var _Scheduler_updateProcessState = F2((func, id) => { return _Utils_Tuple0; }); -var _Scheduler_registerNewProcess = F3((procId, receiver, procState) => { +var _Scheduler_registerNewProcess = F2((procId, procState) => { /**__DEBUG/ - if (procState === undefined) { + if (_Scheduler_processes.has(procId)) { __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); } //*/ _Scheduler_processes.set(procId, procState); - _Scheduler_receivers.set(procId, receiver); - _Scheduler_mailboxes.set(procId, []); return procId; }); -var _Scheduler_mailboxAdd = F2((message, procId) => { - const mailbox = _Scheduler_mailboxes.get(procId); - /**__DEBUG/ - if (mailbox === undefined) { - __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); - } - //*/ - mailbox.push(message); - return procId; -}); - -const _Scheduler_mailboxReceive = F2((procId, state) => { - const receiver = _Scheduler_receivers.get(procId); - const mailbox = _Scheduler_mailboxes.get(procId); - /**__DEBUG/ - if (receiver === undefined || mailbox === undefined) { - __Debug_crash(12, 'procIdNotRegistered', procId && procId.a && procId.a.__$id); - } - //*/ - const msg = mailbox.shift(); - if (msg === undefined) { - return __Maybe_Nothing; - } else { - return __Maybe_Just(A2(receiver, msg, state)); - } -}); var _Scheduler_working = false; var _Scheduler_queue = []; @@ -168,3 +138,55 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { _Scheduler_readyFlgs.set(procId, newRoot); return _Utils_Tuple0; }); + + +// CHANNELS + +const _Scheduler_channels = new WeakMap(); + +const _Scheduler_registerChannel = channelId => { + _Scheduler_channels.set(channelId, { + messages: [], + wakers: new Set(), + }); + return channel; +} + +const _Scheduler_rawRecv = F2((channelId, onMsg) => { + const channel = _Scheduler_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + const msg = channel.messages.shift(); + if (msg === undefined) { + const onWake = msg => onMsg(msg); + channel.wakers.add(onWake); + return x => { + channel.wakers.delete(onWake); + return x; + }; + } else { + onMsg(msg); + return x => x; + } +}); + +const _Scheduler_rawSend = F2((channelId, msg) => { + const channel = _Scheduler_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + + const wakerIter = channel.wakers[Symbol.iterator](); + const { value: nextWaker, done } = wakerIter.next(); + if (done) { + channel.messages.push(msg); + } else { + nextWaker(msg); + } + return _Utils_Tuple0; +}); diff --git a/src/Platform.elm b/src/Platform.elm index 64493236..25ccdfe6 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -41,6 +41,7 @@ import Json.Encode as Encode import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform.Bag as Bag +import Platform.Channel as Channel import Platform.Cmd exposing (Cmd) import Platform.RawScheduler as RawScheduler import Platform.Sub exposing (Sub) @@ -140,6 +141,7 @@ type Router appMsg selfMsg = Router { sendToApp : appMsg -> () , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + , channel : Channel.Channel (ReceivedData appMsg selfMsg) } @@ -160,14 +162,14 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task (RawScheduler.map Ok (RawScheduler.send router.selfProcess (Self msg))) + Task (RawScheduler.map Ok (Channel.send router.channel (Self msg))) -- HELPERS -- -setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) +setupOutgoingPort : (Encode.Value -> ()) -> Channel.Channel (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = let init = @@ -200,7 +202,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) + -> ( Channel.Channel (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -229,7 +231,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Channel (ReceivedData appMsg HiddenSelfMsg) -> () dispatchEffects cmdBag subBag = let @@ -238,7 +240,7 @@ dispatchEffects cmdBag subBag = |> gatherCmds cmdBag |> gatherSubs subBag in - \key selfProcess -> + \key channel -> let ( cmdList, subList ) = Maybe.withDefault @@ -246,8 +248,8 @@ dispatchEffects cmdBag subBag = (Dict.get (effectManagerNameToString key) effectsDict) _ = - RawScheduler.rawSend - selfProcess + Channel.rawSend + channel (App (createHiddenMyCmdList cmdList) (createHiddenMySubList subList)) in () @@ -315,7 +317,7 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + -> Channel.Channel (ReceivedData appMsg selfMsg) setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager sendToAppFunc @@ -329,42 +331,53 @@ instantiateEffectManager : -> RawScheduler.Task state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state) -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state) - -> RawScheduler.ProcessId (ReceivedData appMsg selfMsg) + -> Channel.Channel (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let - receiver msg state = + receiveMsg : + Channel.Channel (ReceivedData appMsg selfMsg) + -> state + -> ReceivedData appMsg selfMsg + -> RawScheduler.Task state + receiveMsg channel state msg = let + task : RawScheduler.Task state task = case msg of Self value -> - onSelfMsg router value state + onSelfMsg (Router router) value state App cmds subs -> - onEffects router cmds subs state + onEffects (Router router) cmds subs state in - RawScheduler.andThen - (\val -> - RawScheduler.map - (\() -> val) - (RawScheduler.sleep 0) - ) - task - - selfProcessInitRoot = - RawScheduler.andThen - (\() -> init) - (RawScheduler.sleep 0) + task + |> RawScheduler.andThen + (\val -> + RawScheduler.map + (\() -> val) + (RawScheduler.sleep 0) + ) + |> RawScheduler.andThen (\newState -> Channel.recv (receiveMsg channel newState) channel) + + initTask : RawScheduler.Task state + initTask = + RawScheduler.sleep 0 + |> RawScheduler.andThen (\_ -> init) + |> RawScheduler.andThen (\state -> Channel.recv (receiveMsg router.channel state) router.channel) selfProcessId = RawScheduler.newProcessId () router = - Router - { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfProcess = selfProcessId - } + { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate + , selfProcess = selfProcessId + , channel = Channel.rawCreateChannel () + } + + _ = + RawScheduler.rawSpawn initTask selfProcessId in - RawScheduler.rawSpawn receiver selfProcessInitRoot selfProcessId + router.channel unwrapTask : Task Never a -> RawScheduler.Task a @@ -437,22 +450,22 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> RawScheduler.ProcessId (ReceivedData Never Never) + , setupOutgoingPort : (Encode.Value -> ()) -> Channel.Channel (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( RawScheduler.ProcessId (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) + -> ( Channel.Channel (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Channel (ReceivedData appMsg HiddenSelfMsg) , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Channel (ReceivedData appMsg HiddenSelfMsg) -> () } diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm new file mode 100644 index 00000000..fe024737 --- /dev/null +++ b/src/Platform/Channel.elm @@ -0,0 +1,59 @@ +module Platform.Channel exposing (Channel, createChannel, rawCreateChannel, rawSend, recv, send) + +import Basics exposing (..) +import Debug +import Elm.Kernel.Scheduler +import Maybe exposing (Maybe(..)) +import Platform.RawScheduler as RawScheduler + + +type Channel msg + = Channel { id : RawScheduler.UniqueId } + + +{-| -} +recv : (msg -> RawScheduler.Task a) -> Channel msg -> RawScheduler.Task a +recv tagger chl = + RawScheduler.AsyncAction + (\doneCallback -> + rawRecv chl (\msg -> doneCallback (tagger msg)) + ) + + +{-| NON PURE! + +Send a message to a channel. If there are tasks waiting for a message then one +will complete during this function call. If there are no tasks waiting the +message will be added to the channel's queue. + +-} +rawSend : Channel msg -> msg -> () +rawSend = + Elm.Kernel.Scheduler.rawSend + + +{-| Create a task, if run, will send a message to a channel. +-} +send : Channel msg -> msg -> RawScheduler.Task () +send channelId msg = + RawScheduler.execImpure (\() -> rawSend channelId msg) + + +rawCreateChannel : () -> Channel msg +rawCreateChannel () = + registerChannel (Channel { id = RawScheduler.getGuid () }) + + +createChannel : () -> RawScheduler.Task (Channel msg) +createChannel () = + RawScheduler.execImpure rawCreateChannel + + +rawRecv : Channel msg -> (msg -> ()) -> RawScheduler.TryAbortAction +rawRecv = + Elm.Kernel.Scheduler.rawRecv + + +registerChannel : Channel msg -> Channel msg +registerChannel = + Elm.Kernel.Scheduler.registerChannel diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index ffbb4018..e4436fb9 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, andThen, execImpure, kill, map, newProcessId, rawSend, rawSpawn, send, sleep, spawn) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, UniqueId, andThen, execImpure, getGuid, kill, map, newProcessId, rawSpawn, sleep, spawn) {-| This module contains the low level logic for running tasks and processes. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -22,6 +22,7 @@ nicer API. `Platform` cannot import `Platform.Scheduler` as -} import Basics exposing (..) +import Debug import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) @@ -90,9 +91,11 @@ map func = Will not register the new process id, just create it. To run any tasks using this process it needs to be registered, for that use `rawSpawn`. -**WARNING**: trying to enqueue (for example by calling `rawSend` or `send`) -this process before it has been registered will give a **runtime** error. (It -may even fail silently in optimized compiles.) +**WARNING**: trying to enqueue this process before it has been registered will +give a **runtime** error. (It may fail silently in optimized compiles.) + +TODO(harry): It might be impossible to enqueue this process now `send` is not +function. -} newProcessId : () -> ProcessId msg @@ -105,53 +108,20 @@ newProcessId () = Will create, register and **enqueue** a new process. -} -rawSpawn : (msg -> a -> Task a) -> Task a -> ProcessId msg -> ProcessId msg -rawSpawn receiver initTask processId = +rawSpawn : Task a -> ProcessId msg -> ProcessId msg +rawSpawn initTask processId = enqueue (registerNewProcess processId - receiver (Ready initTask) ) -{-| NON PURE! - -Send a message to a process (adds the message to the processes mailbox) and -**enqueue** that process. - -If the process is "ready" it will then act upon the next message in its -mailbox. - --} -rawSend : ProcessId msg -> msg -> ProcessId msg -rawSend processId msg = - let - _ = - mailboxAdd msg processId - in - enqueue processId - - -{-| Create a task, if run, will make the process deal with a message. --} -send : ProcessId msg -> msg -> Task () -send processId msg = - execImpure - (\() -> - let - (ProcessId _) = - rawSend processId msg - in - () - ) - - {-| Create a task that spawns a processes. -} -spawn : (msg -> a -> Task a) -> Task a -> Task (ProcessId msg) -spawn receiver task = - execImpure (\() -> rawSpawn receiver task (newProcessId ())) +spawn : Task a -> Task (ProcessId msg) +spawn task = + execImpure (\() -> rawSpawn task (newProcessId ())) {-| Create a task that sleeps for `time` milliseconds @@ -225,12 +195,7 @@ createStateWithRoot : ProcessId msg -> Task state -> ProcessState msg state createStateWithRoot processId root = case root of Value val -> - case mailboxReceive processId val of - Just newRoot -> - createStateWithRoot processId newRoot - - Nothing -> - Ready (Value val) + Ready (Value val) AsyncAction doEffect -> Running @@ -263,22 +228,12 @@ updateProcessState = Elm.Kernel.Scheduler.updateProcessState -mailboxAdd : msg -> ProcessId msg -> msg -mailboxAdd = - Elm.Kernel.Scheduler.mailboxAdd - - -mailboxReceive : ProcessId msg -> state -> Maybe (Task state) -mailboxReceive = - Elm.Kernel.Scheduler.mailboxReceive - - getProcessState : ProcessId msg -> ProcessState msg state getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg -> (msg -> state -> Task state) -> ProcessState msg state -> ProcessId msg +registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index b4e15dfa..19893218 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, send, sleep, spawn, succeed) +module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. @@ -114,13 +114,6 @@ onError func = ) -{-| Create a task, if run, will make the process deal with a message. --} -send : ProcessId msg -> msg -> Platform.Task never () -send proc msg = - wrapTask (RawScheduler.map Ok (RawScheduler.send proc msg)) - - {-| Create a task that, when run, will spawn a process. There is no way to send messages to a process spawned in this way. @@ -132,7 +125,7 @@ spawn = (\task -> RawScheduler.map (\proc -> Ok (wrapProcessId proc)) - (RawScheduler.spawn (\msg _ -> never msg) task) + (RawScheduler.spawn task) ) @@ -147,7 +140,6 @@ rawSpawn = (\task -> wrapProcessId (RawScheduler.rawSpawn - (\msg _ -> never msg) task (RawScheduler.newProcessId ()) ) From 250acab17cfff4c750bba96df2c4bf5734f6684e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 19 Mar 2020 23:05:36 +0000 Subject: [PATCH 085/170] move defintion above usage in js --- src/Elm/Kernel/Platform.js | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 11bbf273..e346c394 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -34,6 +34,9 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); } + const managers = {}; + const ports = {}; + const dispatch = (model, cmds) => { _Platform_effectsQueue.push({ __cmds: cmds, @@ -70,8 +73,6 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { dispatch(model, updateValue.b); }); - const managers = {}; - const ports = {}; for (const [key, {__setup}] of Object.entries(_Platform_effectManagers)) { managers[key] = __setup(functions.__$setupEffects, sendToApp); } From 240d54b1d030776f40d336016ef1de102567e3a6 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 11:20:36 +0000 Subject: [PATCH 086/170] remove waker from wakers before waking otherwise the onWake function gets called twice --- src/Elm/Kernel/Scheduler.js | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 18fafdba..a93294fb 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -186,6 +186,7 @@ const _Scheduler_rawSend = F2((channelId, msg) => { if (done) { channel.messages.push(msg); } else { + channel.wakers.delete(nextWaker); nextWaker(msg); } return _Utils_Tuple0; From 8cde0b1b72980b8fcdebca348fd12625167f4712 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 11:21:35 +0000 Subject: [PATCH 087/170] merge a couple of kernel functions --- src/Elm/Kernel/Debug.js | 4 +- src/Elm/Kernel/Scheduler.js | 89 ++++++++++++++++++++--------------- src/Platform/RawScheduler.elm | 13 ++--- 3 files changed, 57 insertions(+), 49 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 0c1c89fb..a9295d14 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -325,11 +325,13 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) case 'earlyMsg': throw new Error(`Bug in elm runtime: an event manager received a message before it was ready.`); + + case 'procIdAlreadyReady': + throw new Error(`Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared`); } throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); } } - throw new Error(`Unknown error id: ${identifier}!`); } function _Debug_regionToString(region) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index a93294fb..0ff4ad54 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -50,28 +50,12 @@ function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.id); + __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.__$id); } //*/ return procState; } -var _Scheduler_updateProcessState = F2((func, id) => { - const procState = _Scheduler_processes.get(id); - /**__DEBUG/ - if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.__$id); - } - //*/ - const updatedState = func(procState); - /**__DEBUG/ - if (procState !== _Scheduler_processes.get(id)) { - __Debug_crash(12, 'reentrantProcUpdate', id && id.a && id.a.__$id); - } - //*/ - _Scheduler_processes.set(id, updatedState); - return _Utils_Tuple0; -}); var _Scheduler_registerNewProcess = F2((procId, procState) => { /**__DEBUG/ @@ -85,27 +69,49 @@ var _Scheduler_registerNewProcess = F2((procId, procState) => { -var _Scheduler_working = false; -var _Scheduler_queue = []; +const _Scheduler_enqueueWithStepper = stepper => { + let working = false; + const queue = []; -var _Scheduler_enqueueWithStepper = F2(function(stepper, procId) -{ - _Scheduler_queue.push(procId); - if (_Scheduler_working) - { - return procId; - } - _Scheduler_working = true; - while (true) - { - const newProcId = _Scheduler_queue.shift(); - if (newProcId === undefined) { - _Scheduler_working = false; + const stepProccessWithId = newProcId => { + const procState = _Scheduler_processes.get(newProcId); + /**__DEBUG/ + if (procState === undefined) { + __Debug_crash(12, 'procIdNotRegistered', newProcId && newProcId.a && newProcId.a.__$id); + } + //*/ + const updatedState = A2(stepper, newProcId, procState); + /**__DEBUG/ + if (procState !== _Scheduler_processes.get(newProcId)) { + __Debug_crash(12, 'reentrantProcUpdate', newProcId && newProcId.a && newProcId.a.__$id); + } + //*/ + _Scheduler_processes.set(newProcId, updatedState); + }; + + return procId => { + /**__DEBUG/ + if (queue.some(p => p.a.__$id === procId.a.__$id)) { + __Debug_crash(12, 'procIdAlreadyInQueue', procId && procId.a && procId.a.__$id); + } + //*/ + queue.push(procId); + if (working) + { return procId; } - stepper(newProcId); - } -}); + working = true; + while (true) + { + const newProcId = queue.shift(); + if (newProcId === undefined) { + working = false; + return procId; + } + stepProccessWithId(newProcId); + } + }; +}; var _Scheduler_delay = F3(function (time, value, callback) @@ -132,7 +138,12 @@ const _Scheduler_getWokenValue = procId => { const _Scheduler_setWakeTask = F2((procId, newRoot) => { /**__DEBUG/ if (_Scheduler_readyFlgs.has(procId)) { - __Debug_crash(12, 'procIdAlreadyReady', procId && procId.a && procId.a.__$id); + __Debug_crash( + 12, + 'procIdAlreadyReady', + procId && procId.a && procId.a.__$id, + _Scheduler_readyFlgs.get(procId) + ); } //*/ _Scheduler_readyFlgs.set(procId, newRoot); @@ -149,7 +160,7 @@ const _Scheduler_registerChannel = channelId => { messages: [], wakers: new Set(), }); - return channel; + return channelId; } const _Scheduler_rawRecv = F2((channelId, onMsg) => { @@ -161,7 +172,9 @@ const _Scheduler_rawRecv = F2((channelId, onMsg) => { //*/ const msg = channel.messages.shift(); if (msg === undefined) { - const onWake = msg => onMsg(msg); + const onWake = msg => { + return onMsg(msg); + } channel.wakers.add(onWake); return x => { channel.wakers.delete(onWake); diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index e4436fb9..12e82232 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -160,10 +160,8 @@ Returns the enqueued `Process`. -} enqueue : ProcessId msg -> ProcessId msg -enqueue id = - enqueueWithStepper - (\procId -> updateProcessState (stepper procId) procId) - id +enqueue = + enqueueWithStepper stepper @@ -223,11 +221,6 @@ getGuid = Elm.Kernel.Scheduler.getGuid -updateProcessState : (ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> () -updateProcessState = - Elm.Kernel.Scheduler.updateProcessState - - getProcessState : ProcessId msg -> ProcessState msg state getProcessState = Elm.Kernel.Scheduler.getProcessState @@ -238,7 +231,7 @@ registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess -enqueueWithStepper : (ProcessId msg -> ()) -> ProcessId msg -> ProcessId msg +enqueueWithStepper : (ProcessId msg -> ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessId msg enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper From d2f8762a493de1860c695544c57d0da27e1b9f12 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 15:10:33 +0000 Subject: [PATCH 088/170] consolidate process id creation and registration --- src/Platform.elm | 19 +++++++------------ src/Platform/RawScheduler.elm | 27 +++++---------------------- 2 files changed, 12 insertions(+), 34 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 25ccdfe6..e706f001 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -140,8 +140,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp : appMsg -> () - , selfProcess : RawScheduler.ProcessId (ReceivedData appMsg selfMsg) - , channel : Channel.Channel (ReceivedData appMsg selfMsg) + , selfChannel : Channel.Channel (ReceivedData appMsg selfMsg) } @@ -162,7 +161,7 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task (RawScheduler.map Ok (Channel.send router.channel (Self msg))) + Task (RawScheduler.map Ok (Channel.send router.selfChannel (Self msg))) @@ -363,21 +362,17 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = initTask = RawScheduler.sleep 0 |> RawScheduler.andThen (\_ -> init) - |> RawScheduler.andThen (\state -> Channel.recv (receiveMsg router.channel state) router.channel) - - selfProcessId = - RawScheduler.newProcessId () + |> RawScheduler.andThen (\state -> Channel.recv (receiveMsg router.selfChannel state) router.selfChannel) router = { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfProcess = selfProcessId - , channel = Channel.rawCreateChannel () + , selfChannel = Channel.rawCreateChannel () } - _ = - RawScheduler.rawSpawn initTask selfProcessId + selfProcessId = + RawScheduler.rawSpawn initTask in - router.channel + router.selfChannel unwrapTask : Task Never a -> RawScheduler.Task a diff --git a/src/Platform/RawScheduler.elm b/src/Platform/RawScheduler.elm index 12e82232..0bfe5d33 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/RawScheduler.elm @@ -1,4 +1,4 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, UniqueId, andThen, execImpure, getGuid, kill, map, newProcessId, rawSpawn, sleep, spawn) +module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, UniqueId, andThen, execImpure, getGuid, kill, map, rawSpawn, sleep, spawn) {-| This module contains the low level logic for running tasks and processes. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -86,33 +86,16 @@ map func = andThen (\x -> Value (func x)) -{-| Create a new, unique, process id. - -Will not register the new process id, just create it. To run any tasks using -this process it needs to be registered, for that use `rawSpawn`. - -**WARNING**: trying to enqueue this process before it has been registered will -give a **runtime** error. (It may fail silently in optimized compiles.) - -TODO(harry): It might be impossible to enqueue this process now `send` is not -function. - --} -newProcessId : () -> ProcessId msg -newProcessId () = - ProcessId { id = getGuid () } - - {-| NON PURE! Will create, register and **enqueue** a new process. -} -rawSpawn : Task a -> ProcessId msg -> ProcessId msg -rawSpawn initTask processId = +rawSpawn : Task a -> ProcessId msg +rawSpawn initTask = enqueue (registerNewProcess - processId + (ProcessId { id = getGuid () }) (Ready initTask) ) @@ -121,7 +104,7 @@ rawSpawn initTask processId = -} spawn : Task a -> Task (ProcessId msg) spawn task = - execImpure (\() -> rawSpawn task (newProcessId ())) + execImpure (\() -> rawSpawn task) {-| Create a task that sleeps for `time` milliseconds From 1b8fafea9a916e3908251c1ac283d84c4ffdde79 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 15:31:45 +0000 Subject: [PATCH 089/170] move raw modules around --- src/Platform.elm | 51 +++++---- src/Platform/{ => Raw}/Channel.elm | 19 ++-- .../{RawScheduler.elm => Raw/Scheduler.elm} | 107 +++--------------- src/Platform/Raw/Task.elm | 71 ++++++++++++ src/Platform/Scheduler.elm | 41 ++++--- 5 files changed, 144 insertions(+), 145 deletions(-) rename src/Platform/{ => Raw}/Channel.elm (65%) rename src/Platform/{RawScheduler.elm => Raw/Scheduler.elm} (50%) create mode 100644 src/Platform/Raw/Task.elm diff --git a/src/Platform.elm b/src/Platform.elm index e706f001..6d8d25a5 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -41,9 +41,10 @@ import Json.Encode as Encode import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform.Bag as Bag -import Platform.Channel as Channel +import Platform.Raw.Channel as Channel import Platform.Cmd exposing (Cmd) -import Platform.RawScheduler as RawScheduler +import Platform.Raw.Scheduler as RawScheduler +import Platform.Raw.Task as RawTask import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) @@ -119,7 +120,7 @@ information on this. It is only defined here because it is a platform primitive. -} type Task err ok - = Task (RawScheduler.Task (Result err ok)) + = Task (RawTask.Task (Result err ok)) {-| Head over to the documentation for the [`Process`](Process) module for @@ -149,7 +150,7 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Task (RawScheduler.execImpure (\() -> Ok (router.sendToApp msg))) + Task (RawTask.execImpure (\() -> Ok (router.sendToApp msg))) {-| Send the router a message for your effect manager. This message will @@ -161,7 +162,7 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task (RawScheduler.map Ok (Channel.send router.selfChannel (Self msg))) + Task (RawTask.map Ok (Channel.send router.selfChannel (Self msg))) @@ -172,7 +173,7 @@ setupOutgoingPort : (Encode.Value -> ()) -> Channel.Channel (ReceivedData Never setupOutgoingPort outgoingPortSend = let init = - RawScheduler.Value () + RawTask.Value () onSelfMsg _ selfMsg () = never selfMsg @@ -182,9 +183,9 @@ setupOutgoingPort outgoingPortSend = -> List (HiddenMyCmd Never) -> List (HiddenMySub Never) -> () - -> RawScheduler.Task () + -> RawTask.Task () onEffects _ cmdList _ () = - RawScheduler.execImpure + RawTask.execImpure (\() -> let _ = @@ -205,13 +206,13 @@ setupIncomingPort : setupIncomingPort sendToApp2 updateSubs = let init = - RawScheduler.Value () + RawTask.Value () onSelfMsg _ selfMsg () = never selfMsg onEffects _ _ subList () = - RawScheduler.execImpure (\() -> updateSubs subList) + RawTask.execImpure (\() -> updateSubs subList) onSend value subs = List.foldr @@ -327,9 +328,9 @@ setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager : SendToApp appMsg - -> RawScheduler.Task state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawScheduler.Task state) - -> (Router appMsg selfMsg -> selfMsg -> state -> RawScheduler.Task state) + -> RawTask.Task state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawTask.Task state) + -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) -> Channel.Channel (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let @@ -337,10 +338,10 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = Channel.Channel (ReceivedData appMsg selfMsg) -> state -> ReceivedData appMsg selfMsg - -> RawScheduler.Task state + -> RawTask.Task state receiveMsg channel state msg = let - task : RawScheduler.Task state + task : RawTask.Task state task = case msg of Self value -> @@ -350,19 +351,19 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = onEffects (Router router) cmds subs state in task - |> RawScheduler.andThen + |> RawTask.andThen (\val -> - RawScheduler.map + RawTask.map (\() -> val) - (RawScheduler.sleep 0) + (RawTask.sleep 0) ) - |> RawScheduler.andThen (\newState -> Channel.recv (receiveMsg channel newState) channel) + |> RawTask.andThen (\newState -> Channel.recv (receiveMsg channel newState) channel) - initTask : RawScheduler.Task state + initTask : RawTask.Task state initTask = - RawScheduler.sleep 0 - |> RawScheduler.andThen (\_ -> init) - |> RawScheduler.andThen (\state -> Channel.recv (receiveMsg router.selfChannel state) router.selfChannel) + RawTask.sleep 0 + |> RawTask.andThen (\_ -> init) + |> RawTask.andThen (\state -> Channel.recv (receiveMsg router.selfChannel state) router.selfChannel) router = { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate @@ -375,9 +376,9 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = router.selfChannel -unwrapTask : Task Never a -> RawScheduler.Task a +unwrapTask : Task Never a -> RawTask.Task a unwrapTask (Task task) = - RawScheduler.map + RawTask.map (\res -> case res of Ok val -> diff --git a/src/Platform/Channel.elm b/src/Platform/Raw/Channel.elm similarity index 65% rename from src/Platform/Channel.elm rename to src/Platform/Raw/Channel.elm index fe024737..9a36eb33 100644 --- a/src/Platform/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,10 +1,11 @@ -module Platform.Channel exposing (Channel, createChannel, rawCreateChannel, rawSend, recv, send) +module Platform.Raw.Channel exposing (Channel, createChannel, rawCreateChannel, rawSend, recv, send) import Basics exposing (..) import Debug import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) -import Platform.RawScheduler as RawScheduler +import Platform.Raw.Scheduler as RawScheduler +import Platform.Raw.Task as RawTask type Channel msg @@ -12,9 +13,9 @@ type Channel msg {-| -} -recv : (msg -> RawScheduler.Task a) -> Channel msg -> RawScheduler.Task a +recv : (msg -> RawTask.Task a) -> Channel msg -> RawTask.Task a recv tagger chl = - RawScheduler.AsyncAction + RawTask.AsyncAction (\doneCallback -> rawRecv chl (\msg -> doneCallback (tagger msg)) ) @@ -34,9 +35,9 @@ rawSend = {-| Create a task, if run, will send a message to a channel. -} -send : Channel msg -> msg -> RawScheduler.Task () +send : Channel msg -> msg -> RawTask.Task () send channelId msg = - RawScheduler.execImpure (\() -> rawSend channelId msg) + RawTask.execImpure (\() -> rawSend channelId msg) rawCreateChannel : () -> Channel msg @@ -44,12 +45,12 @@ rawCreateChannel () = registerChannel (Channel { id = RawScheduler.getGuid () }) -createChannel : () -> RawScheduler.Task (Channel msg) +createChannel : () -> RawTask.Task (Channel msg) createChannel () = - RawScheduler.execImpure rawCreateChannel + RawTask.execImpure rawCreateChannel -rawRecv : Channel msg -> (msg -> ()) -> RawScheduler.TryAbortAction +rawRecv : Channel msg -> (msg -> ()) -> RawTask.TryAbortAction rawRecv = Elm.Kernel.Scheduler.rawRecv diff --git a/src/Platform/RawScheduler.elm b/src/Platform/Raw/Scheduler.elm similarity index 50% rename from src/Platform/RawScheduler.elm rename to src/Platform/Raw/Scheduler.elm index 0bfe5d33..f07a1f4b 100644 --- a/src/Platform/RawScheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -1,23 +1,7 @@ -module Platform.RawScheduler exposing (DoneCallback, ProcessId(..), Task(..), TryAbortAction, UniqueId, andThen, execImpure, getGuid, kill, map, rawSpawn, sleep, spawn) - -{-| This module contains the low level logic for running tasks and processes. A -`Task` is a sequence of actions (either syncronous or asyncronous) that will be -run in order by the runtime. A process (outside this module a process is -accessed and manipulated using its unique id) is a task paired with a -"receiver". If a process is sent a message (using the `send` function) it is -added to the processes mailbox. When the process completes execution of its -current `Task` (or immediately if it has already finished execution of its -`Task`) it will envoke its receiver function with the oldest message in the -mailbox and the final state of its `Task`. The receiver function should produce -a new `Task` for the process to execute. - -Processes spawned by user elm code (using `Process.spawn`) cannot receive -messages so will execute their initial `Task` and then die. - -Only two modules should import this module directly `Platform.Scheduler` and -`Platform`. All other modules should import `Platform.Scheduler` which has a -nicer API. `Platform` cannot import `Platform.Scheduler` as -`Platfrom.Scheduler` imports `Platform` and elm does not allow import cycles. +module Platform.Raw.Scheduler exposing (UniqueId, ProcessId, getGuid, kill, rawSpawn, spawn) + +{-| This module contains the low level logic for processes. A process is a +unique id used to execute tasks. -} @@ -26,23 +10,12 @@ import Debug import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) - -type Task val - = Value val - | AsyncAction (DoneCallback val -> TryAbortAction) - - -type alias DoneCallback val = - Task val -> () - - -type alias TryAbortAction = - () -> () +import Platform.Raw.Task as RawTask type ProcessState msg state - = Ready (Task state) - | Running TryAbortAction + = Ready (RawTask.Task state) + | Running RawTask.TryAbortAction type ProcessId msg @@ -53,45 +26,12 @@ type UniqueId = UniqueId UniqueId -andThen : (a -> Task b) -> Task a -> Task b -andThen func task = - case task of - Value val -> - func val - - AsyncAction doEffect -> - AsyncAction - (\doneCallback -> - doEffect - (\newTask -> doneCallback (andThen func newTask)) - ) - - -{-| Create a task that executes a non pure function --} -execImpure : (() -> a) -> Task a -execImpure func = - AsyncAction - (\doneCallback -> - let - () = - doneCallback (Value (func ())) - in - \() -> () - ) - - -map : (a -> b) -> Task a -> Task b -map func = - andThen (\x -> Value (func x)) - - {-| NON PURE! Will create, register and **enqueue** a new process. -} -rawSpawn : Task a -> ProcessId msg +rawSpawn : RawTask.Task a -> ProcessId msg rawSpawn initTask = enqueue (registerNewProcess @@ -102,16 +42,10 @@ rawSpawn initTask = {-| Create a task that spawns a processes. -} -spawn : Task a -> Task (ProcessId msg) +spawn : RawTask.Task a -> RawTask.Task (ProcessId msg) spawn task = - execImpure (\() -> rawSpawn task) - + RawTask.execImpure (\() -> rawSpawn task) -{-| Create a task that sleeps for `time` milliseconds --} -sleep : Float -> Task () -sleep time = - AsyncAction (delay time (Value ())) {-| Create a task kills a process. @@ -122,9 +56,9 @@ on the offical core library to lead the way regarding processes that can receive values. -} -kill : ProcessId Never -> Task () +kill : ProcessId Never -> RawTask.Task () kill processId = - execImpure + RawTask.execImpure (\() -> case getProcessState processId of Running killer -> @@ -172,13 +106,13 @@ stepper processId process = createStateWithRoot processId root -createStateWithRoot : ProcessId msg -> Task state -> ProcessState msg state +createStateWithRoot : ProcessId msg -> RawTask.Task state -> ProcessState msg state createStateWithRoot processId root = case root of - Value val -> - Ready (Value val) + RawTask.Value val -> + Ready (RawTask.Value val) - AsyncAction doEffect -> + RawTask.AsyncAction doEffect -> Running (doEffect (\newRoot -> @@ -219,16 +153,11 @@ enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper -delay : Float -> Task val -> DoneCallback val -> TryAbortAction -delay = - Elm.Kernel.Scheduler.delay - - -getWokenValue : ProcessId msg -> Maybe (Task state) +getWokenValue : ProcessId msg -> Maybe (RawTask.Task state) getWokenValue = Elm.Kernel.Scheduler.getWokenValue -setWakeTask : ProcessId msg -> Task state -> () +setWakeTask : ProcessId msg -> RawTask.Task state -> () setWakeTask = Elm.Kernel.Scheduler.setWakeTask diff --git a/src/Platform/Raw/Task.elm b/src/Platform/Raw/Task.elm new file mode 100644 index 00000000..0c50ff82 --- /dev/null +++ b/src/Platform/Raw/Task.elm @@ -0,0 +1,71 @@ +module Platform.Raw.Task exposing (DoneCallback, Task(..), TryAbortAction, andThen, execImpure, map, sleep) + +{-| This module contains the low level logic for tasks. A +`Task` is a sequence of actions (either syncronous or asyncronous) that will be +run in order by the runtime. + +-} + +import Basics exposing (..) +import Debug +import Elm.Kernel.Scheduler +import Maybe exposing (Maybe(..)) + + +type Task val + = Value val + | AsyncAction (DoneCallback val -> TryAbortAction) + + +type alias DoneCallback val = + Task val -> () + + +type alias TryAbortAction = + () -> () + + +andThen : (a -> Task b) -> Task a -> Task b +andThen func task = + case task of + Value val -> + func val + + AsyncAction doEffect -> + AsyncAction + (\doneCallback -> + doEffect + (\newTask -> doneCallback (andThen func newTask)) + ) + + +{-| Create a task that executes a non pure function +-} +execImpure : (() -> a) -> Task a +execImpure func = + AsyncAction + (\doneCallback -> + let + () = + doneCallback (Value (func ())) + in + \() -> () + ) + + +map : (a -> b) -> Task a -> Task b +map func = + andThen (\x -> Value (func x)) + + + +{-| Create a task that sleeps for `time` milliseconds +-} +sleep : Float -> Task () +sleep time = + AsyncAction (delay time (Value ())) + + +delay : Float -> Task val -> DoneCallback val -> TryAbortAction +delay = + Elm.Kernel.Scheduler.delay diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 19893218..ac56ba8d 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,5 +1,5 @@ -module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed) +module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. @@ -46,7 +46,8 @@ import Basics exposing (..) import Elm.Kernel.Basics import Elm.Kernel.Platform import Platform -import Platform.RawScheduler as RawScheduler +import Platform.Raw.Scheduler as RawScheduler +import Platform.Raw.Task as RawTask import Result exposing (Result(..)) @@ -59,23 +60,23 @@ type alias DoneCallback err ok = type alias TryAbortAction = - RawScheduler.TryAbortAction + RawTask.TryAbortAction succeed : ok -> Platform.Task never ok succeed val = - wrapTask (RawScheduler.Value (Ok val)) + wrapTask (RawTask.Value (Ok val)) fail : err -> Platform.Task err never fail e = - wrapTask (RawScheduler.Value (Err e)) + wrapTask (RawTask.Value (Err e)) binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok binding callback = wrapTask - (RawScheduler.AsyncAction + (RawTask.AsyncAction (\doneCallback -> callback (taskFn (\task -> doneCallback task))) ) @@ -84,14 +85,14 @@ andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Ta andThen func = wrapTaskFn (\task -> - RawScheduler.andThen + RawTask.andThen (\r -> case r of Ok val -> unwrapTask (func val) Err e -> - RawScheduler.Value (Err e) + RawTask.Value (Err e) ) task ) @@ -101,11 +102,11 @@ onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.T onError func = wrapTaskFn (\task -> - RawScheduler.andThen + RawTask.andThen (\r -> case r of Ok val -> - RawScheduler.Value (Ok val) + RawTask.Value (Ok val) Err e -> unwrapTask (func e) @@ -123,7 +124,7 @@ spawn : Platform.Task err ok -> Platform.Task never Platform.ProcessId spawn = wrapTaskFn (\task -> - RawScheduler.map + RawTask.map (\proc -> Ok (wrapProcessId proc)) (RawScheduler.spawn task) ) @@ -138,11 +139,7 @@ rawSpawn : Platform.Task err ok -> Platform.ProcessId rawSpawn = taskFn (\task -> - wrapProcessId - (RawScheduler.rawSpawn - task - (RawScheduler.newProcessId ()) - ) + wrapProcessId (RawScheduler.rawSpawn task) ) @@ -150,36 +147,36 @@ rawSpawn = -} kill : Platform.ProcessId -> Platform.Task never () kill processId = - wrapTask (RawScheduler.map Ok (RawScheduler.kill (unwrapProcessId processId))) + wrapTask (RawTask.map Ok (RawScheduler.kill (unwrapProcessId processId))) {-| Create a task that sleeps for `time` milliseconds -} sleep : Float -> Platform.Task x () sleep time = - wrapTask (RawScheduler.map Ok (RawScheduler.sleep time)) + wrapTask (RawTask.map Ok (RawTask.sleep time)) -- wrapping helpers -- -wrapTaskFn : (RawScheduler.Task (Result e1 o1) -> RawScheduler.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 +wrapTaskFn : (RawTask.Task (Result e1 o1) -> RawTask.Task (Result e2 o2)) -> Platform.Task e1 o1 -> Platform.Task e2 o2 wrapTaskFn fn task = wrapTask (taskFn fn task) -taskFn : (RawScheduler.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a +taskFn : (RawTask.Task (Result e1 o1) -> a) -> Platform.Task e1 o1 -> a taskFn fn task = fn (unwrapTask task) -wrapTask : RawScheduler.Task (Result e o) -> Platform.Task e o +wrapTask : RawTask.Task (Result e o) -> Platform.Task e o wrapTask = Elm.Kernel.Platform.wrapTask -unwrapTask : Platform.Task e o -> RawScheduler.Task (Result e o) +unwrapTask : Platform.Task e o -> RawTask.Task (Result e o) unwrapTask = Elm.Kernel.Basics.unwrapTypeWrapper From 81b8974126793e4eddc2c733968485275b7e6177 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 15:56:06 +0000 Subject: [PATCH 090/170] split channel in sender and receiver parts --- src/Elm/Kernel/Scheduler.js | 12 ++++++++---- src/Platform.elm | 36 +++++++++++++++++++++--------------- src/Platform/Raw/Channel.elm | 34 +++++++++++++++++----------------- 3 files changed, 46 insertions(+), 36 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 0ff4ad54..8a3cc6b8 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -3,7 +3,7 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) import Maybe exposing (Just, Nothing) import Elm.Kernel.Debug exposing (crash) -import Elm.Kernel.Utils exposing (Tuple0) +import Elm.Kernel.Utils exposing (Tuple0, Tuple2) */ // COMPATIBILITY @@ -154,13 +154,17 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { // CHANNELS const _Scheduler_channels = new WeakMap(); +let _Scheduler_channelId = 0; -const _Scheduler_registerChannel = channelId => { - _Scheduler_channels.set(channelId, { +const _Scheduler_rawUnbounded = _ => { + const id = { + id: _Scheduler_channelId++ + }; + _Scheduler_channels.set(id, { messages: [], wakers: new Set(), }); - return channelId; + return _Utils_Tuple2(id, id); } const _Scheduler_rawRecv = F2((channelId, onMsg) => { diff --git a/src/Platform.elm b/src/Platform.elm index 6d8d25a5..9b9b3577 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -39,6 +39,7 @@ import Elm.Kernel.Platform import Json.Decode exposing (Decoder) import Json.Encode as Encode import List exposing ((::)) +import Tuple import Maybe exposing (Maybe(..)) import Platform.Bag as Bag import Platform.Raw.Channel as Channel @@ -141,7 +142,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp : appMsg -> () - , selfChannel : Channel.Channel (ReceivedData appMsg selfMsg) + , selfSender : Channel.Sender (ReceivedData appMsg selfMsg) } @@ -162,14 +163,14 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task (RawTask.map Ok (Channel.send router.selfChannel (Self msg))) + Task (RawTask.map Ok (Channel.send router.selfSender (Self msg))) -- HELPERS -- -setupOutgoingPort : (Encode.Value -> ()) -> Channel.Channel (ReceivedData Never Never) +setupOutgoingPort : (Encode.Value -> ()) -> Channel.Sender (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = let init = @@ -202,7 +203,7 @@ setupOutgoingPort outgoingPortSend = setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) - -> ( Channel.Channel (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) + -> ( Channel.Sender (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) setupIncomingPort sendToApp2 updateSubs = let init = @@ -231,7 +232,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> Channel.Channel (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) -> () dispatchEffects cmdBag subBag = let @@ -317,7 +318,7 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> Channel.Channel (ReceivedData appMsg selfMsg) + -> Channel.Sender (ReceivedData appMsg selfMsg) setupEffects sendToAppFunc init onEffects onSelfMsg = instantiateEffectManager sendToAppFunc @@ -331,11 +332,11 @@ instantiateEffectManager : -> RawTask.Task state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawTask.Task state) -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) - -> Channel.Channel (ReceivedData appMsg selfMsg) + -> Channel.Sender (ReceivedData appMsg selfMsg) instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = let receiveMsg : - Channel.Channel (ReceivedData appMsg selfMsg) + Channel.Receiver (ReceivedData appMsg selfMsg) -> state -> ReceivedData appMsg selfMsg -> RawTask.Task state @@ -363,17 +364,22 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = initTask = RawTask.sleep 0 |> RawTask.andThen (\_ -> init) - |> RawTask.andThen (\state -> Channel.recv (receiveMsg router.selfChannel state) router.selfChannel) + |> RawTask.andThen (\state -> Channel.recv (receiveMsg selfReceiver state) selfReceiver) + + + (selfSender, selfReceiver) = + Channel.rawUnbounded () + router = { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfChannel = Channel.rawCreateChannel () + , selfSender = selfSender } selfProcessId = RawScheduler.rawSpawn initTask in - router.selfChannel + selfSender unwrapTask : Task Never a -> RawTask.Task a @@ -446,22 +452,22 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> Channel.Channel (ReceivedData Never Never) + , setupOutgoingPort : (Encode.Value -> ()) -> Channel.Sender (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) - -> ( Channel.Channel (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) + -> ( Channel.Sender (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffects : SendToApp appMsg -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> Channel.Channel (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> Channel.Channel (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) -> () } diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index 9a36eb33..c5de9134 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Channel exposing (Channel, createChannel, rawCreateChannel, rawSend, recv, send) +module Platform.Raw.Channel exposing (Sender, Receiver, unbounded, rawUnbounded, rawSend, recv, send) import Basics exposing (..) import Debug @@ -8,12 +8,16 @@ import Platform.Raw.Scheduler as RawScheduler import Platform.Raw.Task as RawTask -type Channel msg - = Channel { id : RawScheduler.UniqueId } +type Sender msg + = Sender + + +type Receiver msg + = Receiver {-| -} -recv : (msg -> RawTask.Task a) -> Channel msg -> RawTask.Task a +recv : (msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a recv tagger chl = RawTask.AsyncAction (\doneCallback -> @@ -28,33 +32,29 @@ will complete during this function call. If there are no tasks waiting the message will be added to the channel's queue. -} -rawSend : Channel msg -> msg -> () +rawSend : Sender msg -> msg -> () rawSend = Elm.Kernel.Scheduler.rawSend {-| Create a task, if run, will send a message to a channel. -} -send : Channel msg -> msg -> RawTask.Task () +send : Sender msg -> msg -> RawTask.Task () send channelId msg = RawTask.execImpure (\() -> rawSend channelId msg) -rawCreateChannel : () -> Channel msg -rawCreateChannel () = - registerChannel (Channel { id = RawScheduler.getGuid () }) +rawUnbounded : () -> (Sender msg, Receiver msg) +rawUnbounded = + Elm.Kernel.Scheduler.rawUnbounded -createChannel : () -> RawTask.Task (Channel msg) -createChannel () = - RawTask.execImpure rawCreateChannel +unbounded : () -> RawTask.Task (Sender msg, Receiver msg) +unbounded () = + RawTask.execImpure rawUnbounded -rawRecv : Channel msg -> (msg -> ()) -> RawTask.TryAbortAction +rawRecv : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction rawRecv = Elm.Kernel.Scheduler.rawRecv - -registerChannel : Channel msg -> Channel msg -registerChannel = - Elm.Kernel.Scheduler.registerChannel From d05df296943c4f63944e91cd10b02b08bb6c67e4 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 16:15:08 +0000 Subject: [PATCH 091/170] rename managers -> selfSenders As that is what they are now --- src/Elm/Kernel/Platform.js | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index e346c394..a8c6a483 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -34,7 +34,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); } - const managers = {}; + const selfSenders = {}; const ports = {}; const dispatch = (model, cmds) => { @@ -59,9 +59,8 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { fx.__cmds, fx.__subs, ); - for (const key in managers) { - // console.log(managers[key]); - A2(dispatcher, key, managers[key]); + for (const key in selfSenders) { + A2(dispatcher, key, selfSenders[key]); } } } @@ -74,12 +73,12 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { }); for (const [key, {__setup}] of Object.entries(_Platform_effectManagers)) { - managers[key] = __setup(functions.__$setupEffects, sendToApp); + selfSenders[key] = __setup(functions.__$setupEffects, sendToApp); } for (const [key, setup] of Object.entries(_Platform_outgoingPorts)) { const {port, manager} = setup(functions.__$setupOutgoingPort); ports[key] = port; - managers[key] = manager; + selfSenders[key] = manager; } for (const [key, setup] of Object.entries(_Platform_incomingPorts)) { @@ -88,7 +87,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { sendToApp ); ports[key] = port; - managers[key] = manager; + selfSenders[key] = manager; } const initValue = impl.__$init(flagsResult.a); @@ -122,7 +121,20 @@ function _Platform_registerPreload(url) /* Called by compiler generated js when creating event mangers. * - * This function will **always** be call right after page load. + * This function will **always** be call right after page load like this: + * + * _Platform_effectManagers['XXX'] = + * _Platform_createManager($init, $onEffects, $onSelfMsg, $cmdMap); + * + * or + * + * _Platform_effectManagers['XXX'] = + * _Platform_createManager($init, $onEffects, $onSelfMsg, 0, $subMap); + * + * or + * + * _Platform_effectManagers['XXX'] = + * _Platform_createManager($init, $onEffects, $onSelfMsg, $cmdMap, $subMap); */ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { From 7616a3be465e59c3b93d6c367f962e86b729bf13 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 16:25:49 +0000 Subject: [PATCH 092/170] use a Map instead of an object --- src/Elm/Kernel/Platform.js | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index a8c6a483..86ba6291 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -11,8 +11,8 @@ import Platform exposing (Task, ProcessId) // State -var _Platform_outgoingPorts = {}; -var _Platform_incomingPorts = {}; +var _Platform_outgoingPorts = new Map(); +var _Platform_incomingPorts = new Map(); var _Platform_effectManagers = {}; var _Platform_effectsQueue = []; @@ -34,7 +34,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); } - const selfSenders = {}; + const selfSenders = new Map(); const ports = {}; const dispatch = (model, cmds) => { @@ -59,8 +59,8 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { fx.__cmds, fx.__subs, ); - for (const key in selfSenders) { - A2(dispatcher, key, selfSenders[key]); + for (const [key, selfSender] of selfSenders.entries()) { + A2(dispatcher, key, selfSender); } } } @@ -73,21 +73,20 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { }); for (const [key, {__setup}] of Object.entries(_Platform_effectManagers)) { - selfSenders[key] = __setup(functions.__$setupEffects, sendToApp); + selfSenders.set(key, __setup(functions.__$setupEffects, sendToApp)); } - for (const [key, setup] of Object.entries(_Platform_outgoingPorts)) { + for (const [key, setup] of _Platform_outgoingPorts.entries()) { const {port, manager} = setup(functions.__$setupOutgoingPort); ports[key] = port; - selfSenders[key] = manager; + selfSenders.set(key, manager); } - for (const [key, setup] of Object.entries(_Platform_incomingPorts)) - { + for (const [key, setup] of _Platform_incomingPorts.entries()) { const {port, manager} = setup( functions.__$setupIncomingPort, sendToApp ); ports[key] = port; - selfSenders[key] = manager; + selfSenders.set(key, manager); } const initValue = impl.__$init(flagsResult.a); @@ -206,7 +205,7 @@ function _Platform_checkPortName(name) function _Platform_outgoingPort(name, converter) { _Platform_checkPortName(name); - _Platform_outgoingPorts[name] = setup => { + _Platform_outgoingPorts.set(name, setup => { let subs = []; const subscribe = callback => { subs.push(callback); @@ -236,7 +235,7 @@ function _Platform_outgoingPort(name, converter) }, manager: setup(outgoingPortSend), } - } + }); return _Platform_leaf(name) } @@ -245,7 +244,7 @@ function _Platform_outgoingPort(name, converter) function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - _Platform_incomingPorts[name] = function(setup, sendToApp) { + _Platform_incomingPorts.set(name, function(setup, sendToApp) { let subs = __List_Nil; function updateSubs(subsList) { @@ -270,7 +269,7 @@ function _Platform_incomingPort(name, converter) }, manager: setupTuple.a, } - } + }); return _Platform_leaf(name) } @@ -283,7 +282,7 @@ const _Platform_effectManagerNameToString = name => name; const _Platform_getCmdMapper = home => { - if (_Platform_outgoingPorts.hasOwnProperty(home)) { + if (_Platform_outgoingPorts.has(home)) { return F2((_tagger, value) => value); } return _Platform_effectManagers[home].__cmdMapper; @@ -291,7 +290,7 @@ const _Platform_getCmdMapper = home => { const _Platform_getSubMapper = home => { - if (_Platform_incomingPorts.hasOwnProperty(home)) { + if (_Platform_incomingPorts.has(home)) { return F2((tagger, finalTagger) => value => tagger(finalTagger(value))); } return _Platform_effectManagers[home].__subMapper; From 0a0f59c54ed1d373e50e7bdc92a3b7b57b249d26 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 21 Mar 2020 18:51:02 +0000 Subject: [PATCH 093/170] add channel map --- src/Elm/Kernel/Scheduler.js | 2 +- src/Platform/Raw/Channel.elm | 23 +++++++++++++++++------ 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 8a3cc6b8..f4bfd2b8 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -164,7 +164,7 @@ const _Scheduler_rawUnbounded = _ => { messages: [], wakers: new Set(), }); - return _Utils_Tuple2(id, id); + return _Utils_Tuple2(_Scheduler_rawSend(id), id); } const _Scheduler_rawRecv = F2((channelId, onMsg) => { diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index c5de9134..f5745a76 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Channel exposing (Sender, Receiver, unbounded, rawUnbounded, rawSend, recv, send) +module Platform.Raw.Channel exposing (Sender, Receiver, unbounded, rawUnbounded, rawSend, recv, send, mapSender) import Basics exposing (..) import Debug @@ -6,10 +6,11 @@ import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) import Platform.Raw.Scheduler as RawScheduler import Platform.Raw.Task as RawTask +import Tuple type Sender msg - = Sender + = Sender (msg -> ()) type Receiver msg @@ -33,8 +34,8 @@ message will be added to the channel's queue. -} rawSend : Sender msg -> msg -> () -rawSend = - Elm.Kernel.Scheduler.rawSend +rawSend (Sender sender) = + sender {-| Create a task, if run, will send a message to a channel. @@ -45,8 +46,9 @@ send channelId msg = rawUnbounded : () -> (Sender msg, Receiver msg) -rawUnbounded = - Elm.Kernel.Scheduler.rawUnbounded +rawUnbounded () = + Elm.Kernel.Scheduler.rawUnbounded () + |> Tuple.mapFirst Sender unbounded : () -> RawTask.Task (Sender msg, Receiver msg) @@ -58,3 +60,12 @@ rawRecv : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction rawRecv = Elm.Kernel.Scheduler.rawRecv + +mapSender : (b -> a) -> Sender a -> Sender b +mapSender fn (Sender sender) = + Sender (\b -> sender (fn b)) + + +rawUnboundedKernel : () -> (msg -> (), Receiver msg) +rawUnboundedKernel = + Elm.Kernel.Scheduler.rawUnbounded From 3ac7bc3c8f74733f7a2512baa3dcbcc0575b339e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Mar 2020 22:23:10 +0000 Subject: [PATCH 094/170] formatting --- src/Platform/Raw/Channel.elm | 8 ++++---- src/Platform/Raw/Scheduler.elm | 5 +---- src/Platform/Raw/Task.elm | 2 -- src/Platform/Scheduler.elm | 2 +- 4 files changed, 6 insertions(+), 11 deletions(-) diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index f5745a76..94fbbb3a 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Channel exposing (Sender, Receiver, unbounded, rawUnbounded, rawSend, recv, send, mapSender) +module Platform.Raw.Channel exposing (Receiver, Sender, mapSender, rawSend, rawUnbounded, recv, send, unbounded) import Basics exposing (..) import Debug @@ -45,13 +45,13 @@ send channelId msg = RawTask.execImpure (\() -> rawSend channelId msg) -rawUnbounded : () -> (Sender msg, Receiver msg) +rawUnbounded : () -> ( Sender msg, Receiver msg ) rawUnbounded () = Elm.Kernel.Scheduler.rawUnbounded () |> Tuple.mapFirst Sender -unbounded : () -> RawTask.Task (Sender msg, Receiver msg) +unbounded : () -> RawTask.Task ( Sender msg, Receiver msg ) unbounded () = RawTask.execImpure rawUnbounded @@ -66,6 +66,6 @@ mapSender fn (Sender sender) = Sender (\b -> sender (fn b)) -rawUnboundedKernel : () -> (msg -> (), Receiver msg) +rawUnboundedKernel : () -> ( msg -> (), Receiver msg ) rawUnboundedKernel = Elm.Kernel.Scheduler.rawUnbounded diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index f07a1f4b..e091bc57 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -1,15 +1,13 @@ -module Platform.Raw.Scheduler exposing (UniqueId, ProcessId, getGuid, kill, rawSpawn, spawn) +module Platform.Raw.Scheduler exposing (ProcessId, UniqueId, getGuid, kill, rawSpawn, spawn) {-| This module contains the low level logic for processes. A process is a unique id used to execute tasks. - -} import Basics exposing (..) import Debug import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) - import Platform.Raw.Task as RawTask @@ -47,7 +45,6 @@ spawn task = RawTask.execImpure (\() -> rawSpawn task) - {-| Create a task kills a process. To kill a process we should try to abort any ongoing async action. diff --git a/src/Platform/Raw/Task.elm b/src/Platform/Raw/Task.elm index 0c50ff82..ad7fb98d 100644 --- a/src/Platform/Raw/Task.elm +++ b/src/Platform/Raw/Task.elm @@ -3,7 +3,6 @@ module Platform.Raw.Task exposing (DoneCallback, Task(..), TryAbortAction, andTh {-| This module contains the low level logic for tasks. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be run in order by the runtime. - -} import Basics exposing (..) @@ -58,7 +57,6 @@ map func = andThen (\x -> Value (func x)) - {-| Create a task that sleeps for `time` milliseconds -} sleep : Float -> Task () diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index ac56ba8d..038e5c8c 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,5 +1,5 @@ - module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed) + {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. From 935fd235d92a782970820d69b2e6d9580afb8453 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Mar 2020 22:28:17 +0000 Subject: [PATCH 095/170] trial channel based effects with Task module --- src/Elm/Kernel/Platform.js | 5 +++ src/Platform.elm | 92 +++++++++++++++++++++++++++++++++++--- src/Platform/Channel.elm | 42 +++++++++++++++++ src/Platform/Effects.elm | 19 ++++++++ src/Platform/Scheduler.elm | 2 +- src/Task.elm | 55 +++++++---------------- 6 files changed, 170 insertions(+), 45 deletions(-) create mode 100644 src/Platform/Channel.elm create mode 100644 src/Platform/Effects.elm diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 86ba6291..f014999b 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -6,6 +6,7 @@ import Elm.Kernel.List exposing (Cons, Nil) import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) import Platform exposing (Task, ProcessId) +import Platform.Effects as Effects exposing (mapCommand) */ @@ -72,6 +73,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { dispatch(model, updateValue.b); }); + selfSenders.set('000PlatformEffect', functions.__$setupEffectsChannel(sendToApp)); for (const [key, {__setup}] of Object.entries(_Platform_effectManagers)) { selfSenders.set(key, __setup(functions.__$setupEffects, sendToApp)); } @@ -285,6 +287,9 @@ const _Platform_getCmdMapper = home => { if (_Platform_outgoingPorts.has(home)) { return F2((_tagger, value) => value); } + if (home === '000PlatformEffect') { + return __Effects_mapCommand; + } return _Platform_effectManagers[home].__cmdMapper; }; diff --git a/src/Platform.elm b/src/Platform.elm index 9b9b3577..421e0e54 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -39,16 +39,16 @@ import Elm.Kernel.Platform import Json.Decode exposing (Decoder) import Json.Encode as Encode import List exposing ((::)) -import Tuple import Maybe exposing (Maybe(..)) import Platform.Bag as Bag -import Platform.Raw.Channel as Channel import Platform.Cmd exposing (Cmd) +import Platform.Raw.Channel as Channel import Platform.Raw.Scheduler as RawScheduler import Platform.Raw.Task as RawTask import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) +import Tuple @@ -107,6 +107,7 @@ worker impl = , setupIncomingPort = setupIncomingPort , setupEffects = setupEffects , dispatchEffects = dispatchEffects + , setupEffectsChannel = setupEffectsChannel } ) ) @@ -170,6 +171,82 @@ sendToSelf (Router router) msg = -- HELPERS -- +{-| Multiple channels at play here and type fudging means the compiler cannot +always help us if we get confused so be careful! + +The channel who's sender we return is a runtime specific channel, the thunk +returned by dispatchEffects will use the sender to notify this function that we +have command and/or subscriptions to process. + +Each command or subscription is a function `Channel.Sender msg -> Platform.Task +Never ()`. We must call it with a channel that forwards all messages to the +app's main update cycle (i.e. the receiver will call sendToApp2). + +-} +setupEffectsChannel : SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) +setupEffectsChannel sendToApp2 = + let + dispatchChannel : ( Channel.Sender (ReceivedData appMsg Never), Channel.Receiver (ReceivedData appMsg Never) ) + dispatchChannel = + Channel.rawUnbounded () + + appChannel : ( Channel.Sender appMsg, Channel.Receiver appMsg ) + appChannel = + Channel.rawUnbounded () + + receiveMsg : ReceivedData appMsg Never -> RawTask.Task () + receiveMsg msg = + case msg of + Self value -> + never value + + App cmds subs -> + cmds + |> createPlatformEffectFuncs + |> List.map + (\payload channel -> + let + (Task t) = + payload channel + in + RawTask.map + (\r -> + case r of + Ok val -> + val + + Err err -> + never err + ) + t + ) + |> List.foldr + (\curr prev -> + RawTask.andThen + (\() -> curr (Tuple.first appChannel)) + prev + ) + (RawTask.Value ()) + + dispatchTask () = + RawTask.andThen + dispatchTask + (Channel.recv receiveMsg (Tuple.second dispatchChannel)) + + appTask () = + RawTask.andThen + appTask + (Channel.recv (\msg -> RawTask.Value (sendToApp2 msg AsyncUpdate)) (Tuple.second appChannel)) + + _ = + RawScheduler.rawSpawn (dispatchTask ()) + + _ = + RawScheduler.rawSpawn (appTask ()) + in + Tuple.first dispatchChannel + + setupOutgoingPort : (Encode.Value -> ()) -> Channel.Sender (ReceivedData Never Never) setupOutgoingPort outgoingPortSend = let @@ -366,11 +443,9 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = |> RawTask.andThen (\_ -> init) |> RawTask.andThen (\state -> Channel.recv (receiveMsg selfReceiver state) selfReceiver) - - (selfSender, selfReceiver) = + ( selfSender, selfReceiver ) = Channel.rawUnbounded () - router = { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate , selfSender = selfSender @@ -457,6 +532,8 @@ type alias InitFunctions model appMsg = SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) -> ( Channel.Sender (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) + , setupEffectsChannel : + SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) , setupEffects : SendToApp appMsg -> Task Never HiddenState @@ -524,3 +601,8 @@ createValuesToSendOutOfPorts = createIncomingPortConverters : List (HiddenMySub msg) -> List (Encode.Value -> msg) createIncomingPortConverters = Elm.Kernel.Basics.fudgeType + + +createPlatformEffectFuncs : List (HiddenMyCmd msg) -> List (Channel.Sender msg -> Task Never ()) +createPlatformEffectFuncs = + Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm new file mode 100644 index 00000000..ab2c1c53 --- /dev/null +++ b/src/Platform/Channel.elm @@ -0,0 +1,42 @@ +module Platform.Channel exposing (Receiver, Sender, mapSender, recv, send, unbounded) + +import Basics exposing (..) +import Debug +import Elm.Kernel.Scheduler +import Maybe exposing (Maybe(..)) +import Platform +import Platform.Raw.Channel as RawChannel +import Platform.Raw.Task as RawTask +import Platform.Scheduler as Scheduler +import Result exposing (Result(..)) + + +type alias Sender msg = + RawChannel.Sender msg + + +type alias Receiver msg = + RawChannel.Receiver msg + + +{-| -} +recv : (msg -> Platform.Task Never a) -> Receiver msg -> Platform.Task Never a +recv tagger chl = + Scheduler.wrapTask (RawChannel.recv (\msg -> Scheduler.unwrapTask (tagger msg)) chl) + + +{-| Create a task, if run, will send a message to a channel. +-} +send : Sender msg -> msg -> Platform.Task never () +send channelId msg = + Scheduler.wrapTask (RawTask.map Ok (RawChannel.send channelId msg)) + + +unbounded : () -> Platform.Task never ( Sender msg, Receiver msg ) +unbounded () = + Scheduler.wrapTask (RawTask.map Ok (RawChannel.unbounded ())) + + +mapSender : (b -> a) -> Sender a -> Sender b +mapSender = + RawChannel.mapSender diff --git a/src/Platform/Effects.elm b/src/Platform/Effects.elm new file mode 100644 index 00000000..d5e9bd44 --- /dev/null +++ b/src/Platform/Effects.elm @@ -0,0 +1,19 @@ +module Platform.Effects exposing (command) + +import Basics exposing (..) +import Debug +import Elm.Kernel.Platform +import Maybe exposing (Maybe(..)) +import Platform +import Platform.Channel as Channel +import Platform.Cmd as Cmd exposing (Cmd) + + +command : (Channel.Sender msg -> Platform.Task Never ()) -> Cmd msg +command function = + Elm.Kernel.Platform.leaf "000PlatformEffect" function + + +mapCommand : (a -> b) -> (Channel.Sender a -> Platform.Task Never ()) -> (Channel.Sender b -> Platform.Task Never ()) +mapCommand tagger function = + \channel -> function (Channel.mapSender tagger channel) diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 038e5c8c..18945263 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed) +module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed, wrapTask, unwrapTask) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. diff --git a/src/Task.elm b/src/Task.elm index c653d318..cb5f5a09 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -1,4 +1,4 @@ -effect module Task where { command = MyCmd } exposing +module Task exposing ( Task, perform, attempt , andThen, succeed, fail, sequence , map, map2, map3, map4, map5 @@ -34,7 +34,9 @@ import Basics exposing ((<<), (|>), Never, never) import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform +import Platform.Channel import Platform.Cmd exposing (Cmd) +import Platform.Effects import Platform.Scheduler as Scheduler import Result exposing (Result(..)) @@ -336,7 +338,7 @@ delicious lasagna and give it to my `update` function as a `Msg` value." -} perform : (a -> msg) -> Task Never a -> Cmd msg perform toMessage task = - command (Perform (map toMessage task)) + performHelp (map toMessage task) {-| This is very similar to [`perform`](#perform) except it can handle failures! @@ -369,44 +371,19 @@ feeling for how commands fit into The Elm Architecture. -} attempt : (Result x a -> msg) -> Task x a -> Cmd msg attempt resultToMessage task = - command - (Perform - (task - |> andThen (succeed << resultToMessage << Ok) - |> onError (succeed << resultToMessage << Err) - ) + performHelp + (task + |> andThen (succeed << resultToMessage << Ok) + |> onError (succeed << resultToMessage << Err) ) -cmdMap : (a -> b) -> MyCmd a -> MyCmd b -cmdMap tagger (Perform task) = - Perform (map tagger task) - - - --- MANAGER - - -init : Task Never () -init = - succeed () - - -onEffects : Platform.Router msg Never -> List (MyCmd msg) -> () -> Task Never () -onEffects router commands () = - map - (\_ -> ()) - (sequence (List.map (spawnCmd router) commands)) - - -onSelfMsg : Platform.Router msg Never -> Never -> () -> Task Never () -onSelfMsg _ msg () = - never msg - - -spawnCmd : Platform.Router msg Never -> MyCmd msg -> Task x Platform.ProcessId -spawnCmd router (Perform task) = - Scheduler.spawn - (task - |> andThen (Platform.sendToApp router) +performHelp : Task Never msg -> Cmd msg +performHelp task = + Platform.Effects.command + (\toAppSender -> + task + |> andThen (\msg -> Platform.Channel.send toAppSender msg) + |> Scheduler.spawn + |> map (\_ -> ()) ) From b8162eb44e464b73a81cb0c996e190c970ede118 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Mar 2020 22:35:34 +0000 Subject: [PATCH 096/170] tidy effect manager code it should be gone soon anyway --- src/Elm/Kernel/Platform.js | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index f014999b..ad8e396e 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -74,8 +74,15 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { }); selfSenders.set('000PlatformEffect', functions.__$setupEffectsChannel(sendToApp)); - for (const [key, {__setup}] of Object.entries(_Platform_effectManagers)) { - selfSenders.set(key, __setup(functions.__$setupEffects, sendToApp)); + for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { + const manager = A4( + functions.__$setupEffects, + sendToApp, + effectManagerFunctions.__init, + effectManagerFunctions.__fullOnEffects, + effectManagerFunctions.__onSelfMsg + ); + selfSenders.set(key, manager); } for (const [key, setup] of _Platform_outgoingPorts.entries()) { const {port, manager} = setup(functions.__$setupOutgoingPort); @@ -139,33 +146,36 @@ function _Platform_registerPreload(url) */ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { - const make_setup = fullOnEffects => (setup, sendToApp) => { - return A4(setup, sendToApp, init, fullOnEffects, onSelfMsg) - } if (typeof cmdMap !== 'function') { // Subscription only effect module return { __cmdMapper: F2((_1, _2) => __Debug_crash(12, 'cmdMap')), __subMapper: subMap, - __setup: make_setup(F4(function(router, _cmds, subs, state) { + __init: init, + __fullOnEffects: F4(function(router, _cmds, subs, state) { return A3(onEffects, router, subs, state); - })), + }), + __onSelfMsg: onSelfMsg, }; } else if (typeof subMap !== 'function') { // Command only effect module return { __cmdMapper: cmdMap, __subMapper: F2((_1, _2) => __Debug_crash(12, 'subMap')), - __setup: make_setup(F4(function(router, cmds, _subs, state) { + __init: init, + __fullOnEffects: F4(function(router, cmds, _subs, state) { return A3(onEffects, router, cmds, state); - })), + }), + __onSelfMsg: onSelfMsg }; } else { // Command **and** subscription event manager return { __cmdMapper: cmdMap, __subMapper: subMap, - __setup: make_setup(onEffects), + __init: init, + __fullOnEffects: onEffects, + __onSelfMsg: onSelfMsg }; } } From 9210ddbf94963d32b582e80556eea5f648c728e9 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 22 Mar 2020 22:57:41 +0000 Subject: [PATCH 097/170] tidy outgoing port js code --- src/Elm/Kernel/Platform.js | 61 ++++++++++++++++++-------------------- 1 file changed, 29 insertions(+), 32 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index ad8e396e..f58dda6b 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -84,10 +84,9 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { ); selfSenders.set(key, manager); } - for (const [key, setup] of _Platform_outgoingPorts.entries()) { - const {port, manager} = setup(functions.__$setupOutgoingPort); + for (const [key, {port, outgoingPortSend}] of _Platform_outgoingPorts.entries()) { ports[key] = port; - selfSenders.set(key, manager); + selfSenders.set(key, functions.__$setupOutgoingPort(outgoingPortSend)); } for (const [key, setup] of _Platform_incomingPorts.entries()) { const {port, manager} = setup( @@ -217,36 +216,34 @@ function _Platform_checkPortName(name) function _Platform_outgoingPort(name, converter) { _Platform_checkPortName(name); - _Platform_outgoingPorts.set(name, setup => { - let subs = []; - const subscribe = callback => { - subs.push(callback); - }; - const unsubscribe = callback => { - // copy subs into a new array in case unsubscribe is called within - // a subscribed callback - subs = subs.slice(); - var index = subs.indexOf(callback); - if (index >= 0) - { - subs.splice(index, 1); - } - }; - const outgoingPortSend = payload => { - const value = __Json_unwrap(converter(payload)); - for (const sub of subs) - { - sub(value); - } - return __Utils_Tuple0; - }; - return { - port: { - subscribe, - unsubscribe, - }, - manager: setup(outgoingPortSend), + let subs = []; + const subscribe = callback => { + subs.push(callback); + }; + const unsubscribe = callback => { + // copy subs into a new array in case unsubscribe is called within + // a subscribed callback + subs = subs.slice(); + var index = subs.indexOf(callback); + if (index >= 0) + { + subs.splice(index, 1); } + }; + const outgoingPortSend = payload => { + const value = __Json_unwrap(converter(payload)); + for (const sub of subs) + { + sub(value); + } + return __Utils_Tuple0; + }; + _Platform_outgoingPorts.set(name, { + port: { + subscribe, + unsubscribe, + }, + outgoingPortSend, }); return _Platform_leaf(name) From 0ad9832a110d532765edece345cd156e0e2efd29 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 24 Mar 2020 18:37:15 +0000 Subject: [PATCH 098/170] implement outgoing ports using new effects --- src/Elm/Kernel/Platform.js | 17 ++++++++++++----- src/Platform.elm | 36 ++---------------------------------- 2 files changed, 14 insertions(+), 39 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index f58dda6b..4e66e95e 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -7,6 +7,7 @@ import Elm.Kernel.Utils exposing (Tuple0) import Result exposing (isOk) import Platform exposing (Task, ProcessId) import Platform.Effects as Effects exposing (mapCommand) +import Platform.Scheduler as Scheduler exposing (binding, succeed) */ @@ -86,7 +87,6 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { } for (const [key, {port, outgoingPortSend}] of _Platform_outgoingPorts.entries()) { ports[key] = port; - selfSenders.set(key, functions.__$setupOutgoingPort(outgoingPortSend)); } for (const [key, setup] of _Platform_incomingPorts.entries()) { const {port, manager} = setup( @@ -230,23 +230,30 @@ function _Platform_outgoingPort(name, converter) subs.splice(index, 1); } }; - const outgoingPortSend = payload => { + const execSubscribers = payload => { const value = __Json_unwrap(converter(payload)); for (const sub of subs) { sub(value); } return __Utils_Tuple0; - }; + } _Platform_outgoingPorts.set(name, { port: { subscribe, unsubscribe, }, - outgoingPortSend, }); - return _Platform_leaf(name) + return payload => A2( + _Platform_leaf, + '000PlatformEffect', + _ => __Scheduler_binding(doneCallback => { + execSubscribers(payload); + doneCallback(__Scheduler_succeed(__Utils_Tuple0)); + return x => x; + }) + ); } diff --git a/src/Platform.elm b/src/Platform.elm index 421e0e54..860eaca3 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -103,7 +103,6 @@ worker impl = args impl { stepperBuilder = \_ _ -> \_ _ -> () - , setupOutgoingPort = setupOutgoingPort , setupIncomingPort = setupIncomingPort , setupEffects = setupEffects , dispatchEffects = dispatchEffects @@ -239,44 +238,14 @@ setupEffectsChannel sendToApp2 = (Channel.recv (\msg -> RawTask.Value (sendToApp2 msg AsyncUpdate)) (Tuple.second appChannel)) _ = - RawScheduler.rawSpawn (dispatchTask ()) + RawScheduler.rawSpawn (RawTask.andThen dispatchTask (RawTask.sleep 0)) _ = - RawScheduler.rawSpawn (appTask ()) + RawScheduler.rawSpawn (RawTask.andThen appTask (RawTask.sleep 0)) in Tuple.first dispatchChannel -setupOutgoingPort : (Encode.Value -> ()) -> Channel.Sender (ReceivedData Never Never) -setupOutgoingPort outgoingPortSend = - let - init = - RawTask.Value () - - onSelfMsg _ selfMsg () = - never selfMsg - - onEffects : - Router Never Never - -> List (HiddenMyCmd Never) - -> List (HiddenMySub Never) - -> () - -> RawTask.Task () - onEffects _ cmdList _ () = - RawTask.execImpure - (\() -> - let - _ = - cmdList - |> createValuesToSendOutOfPorts - |> List.map outgoingPortSend - in - () - ) - in - instantiateEffectManager never init onEffects onSelfMsg - - setupIncomingPort : SendToApp msg -> (List (HiddenMySub msg) -> ()) @@ -527,7 +496,6 @@ type alias Impl flags model msg = type alias InitFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupOutgoingPort : (Encode.Value -> ()) -> Channel.Sender (ReceivedData Never Never) , setupIncomingPort : SendToApp appMsg -> (List (HiddenMySub appMsg) -> ()) From 65fcf67be2cb6b50e8f52dd5983e3d2471339677 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 24 Mar 2020 18:38:46 +0000 Subject: [PATCH 099/170] use new effect mapCommand for outgoing ports --- src/Elm/Kernel/Platform.js | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 4e66e95e..4d8ddf96 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -298,9 +298,6 @@ const _Platform_effectManagerNameToString = name => name; const _Platform_getCmdMapper = home => { - if (_Platform_outgoingPorts.has(home)) { - return F2((_tagger, value) => value); - } if (home === '000PlatformEffect') { return __Effects_mapCommand; } From 8930c3ecda79dd7b3031f294d900551b78ef6a18 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 24 Mar 2020 18:39:05 +0000 Subject: [PATCH 100/170] remove dead code --- src/Elm/Kernel/Platform.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 4d8ddf96..4a9ce248 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -85,7 +85,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { ); selfSenders.set(key, manager); } - for (const [key, {port, outgoingPortSend}] of _Platform_outgoingPorts.entries()) { + for (const [key, {port}] of _Platform_outgoingPorts.entries()) { ports[key] = port; } for (const [key, setup] of _Platform_incomingPorts.entries()) { From da433633bab1453b74de1b304591c6a2daa3dee4 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 26 Mar 2020 20:16:21 +0000 Subject: [PATCH 101/170] drop msg type param from processes --- src/Platform.elm | 5 +---- src/Platform/Raw/Scheduler.elm | 26 +++++++++++++------------- src/Platform/Scheduler.elm | 8 ++++---- 3 files changed, 18 insertions(+), 21 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 860eaca3..b95d8d05 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -129,7 +129,7 @@ information on this. It is only defined here because it is a platform primitive. -} type ProcessId - = ProcessId (RawScheduler.ProcessId Never) + = ProcessId (RawScheduler.ProcessId) @@ -458,9 +458,6 @@ type UpdateMetadata | AsyncUpdate -type OtherManagers appMsg - = OtherManagers (Dict String (RawScheduler.ProcessId (ReceivedData appMsg HiddenSelfMsg))) - type ReceivedData appMsg selfMsg = Self selfMsg diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index e091bc57..a31e6c21 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -11,12 +11,12 @@ import Maybe exposing (Maybe(..)) import Platform.Raw.Task as RawTask -type ProcessState msg state +type ProcessState state = Ready (RawTask.Task state) | Running RawTask.TryAbortAction -type ProcessId msg +type ProcessId = ProcessId { id : UniqueId } @@ -29,7 +29,7 @@ type UniqueId Will create, register and **enqueue** a new process. -} -rawSpawn : RawTask.Task a -> ProcessId msg +rawSpawn : RawTask.Task a -> ProcessId rawSpawn initTask = enqueue (registerNewProcess @@ -40,7 +40,7 @@ rawSpawn initTask = {-| Create a task that spawns a processes. -} -spawn : RawTask.Task a -> RawTask.Task (ProcessId msg) +spawn : RawTask.Task a -> RawTask.Task (ProcessId) spawn task = RawTask.execImpure (\() -> rawSpawn task) @@ -53,7 +53,7 @@ on the offical core library to lead the way regarding processes that can receive values. -} -kill : ProcessId Never -> RawTask.Task () +kill : ProcessId -> RawTask.Task () kill processId = RawTask.execImpure (\() -> @@ -73,7 +73,7 @@ call, drain the run queue but stepping all processes. Returns the enqueued `Process`. -} -enqueue : ProcessId msg -> ProcessId msg +enqueue : ProcessId -> ProcessId enqueue = enqueueWithStepper stepper @@ -88,7 +88,7 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId msg -> ProcessState msg state -> ProcessState msg state +stepper : ProcessId -> ProcessState state -> ProcessState state stepper processId process = case process of Running _ -> @@ -103,7 +103,7 @@ stepper processId process = createStateWithRoot processId root -createStateWithRoot : ProcessId msg -> RawTask.Task state -> ProcessState msg state +createStateWithRoot : ProcessId -> RawTask.Task state -> ProcessState state createStateWithRoot processId root = case root of RawTask.Value val -> @@ -135,26 +135,26 @@ getGuid = Elm.Kernel.Scheduler.getGuid -getProcessState : ProcessId msg -> ProcessState msg state +getProcessState : ProcessId -> ProcessState state getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId msg -> ProcessState msg state -> ProcessId msg +registerNewProcess : ProcessId -> ProcessState state -> ProcessId registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess -enqueueWithStepper : (ProcessId msg -> ProcessState msg state -> ProcessState msg state) -> ProcessId msg -> ProcessId msg +enqueueWithStepper : (ProcessId -> ProcessState state -> ProcessState state) -> ProcessId -> ProcessId enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper -getWokenValue : ProcessId msg -> Maybe (RawTask.Task state) +getWokenValue : ProcessId -> Maybe (RawTask.Task state) getWokenValue = Elm.Kernel.Scheduler.getWokenValue -setWakeTask : ProcessId msg -> RawTask.Task state -> () +setWakeTask : ProcessId -> RawTask.Task state -> () setWakeTask = Elm.Kernel.Scheduler.setWakeTask diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 18945263..49f27fa2 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -51,8 +51,8 @@ import Platform.Raw.Task as RawTask import Result exposing (Result(..)) -type alias ProcessId msg = - RawScheduler.ProcessId msg +type alias ProcessId = + RawScheduler.ProcessId type alias DoneCallback err ok = @@ -181,11 +181,11 @@ unwrapTask = Elm.Kernel.Basics.unwrapTypeWrapper -wrapProcessId : ProcessId Never -> Platform.ProcessId +wrapProcessId : ProcessId -> Platform.ProcessId wrapProcessId = Elm.Kernel.Platform.wrapProcessId -unwrapProcessId : Platform.ProcessId -> ProcessId Never +unwrapProcessId : Platform.ProcessId -> ProcessId unwrapProcessId = Elm.Kernel.Basics.unwrapTypeWrapper From 120bb5835342cdb0b72270778b677424817b046b Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 2 Apr 2020 19:41:14 +0100 Subject: [PATCH 102/170] add Scheduler.batch and Channel.tryRecv --- src/Elm/Kernel/Scheduler.js | 35 +++++++++++++++++---------- src/Platform/Raw/Channel.elm | 35 ++++++++++++++++++++++++--- src/Platform/Raw/Scheduler.elm | 44 ++++++++++++++++++++++++---------- 3 files changed, 87 insertions(+), 27 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index f4bfd2b8..e7c16c16 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -167,7 +167,25 @@ const _Scheduler_rawUnbounded = _ => { return _Utils_Tuple2(_Scheduler_rawSend(id), id); } -const _Scheduler_rawRecv = F2((channelId, onMsg) => { +const _Scheduler_setWaker = F2((channelId, onMsg) => { + const channel = _Scheduler_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + const onWake = msg => { + return onMsg(msg); + } + channel.wakers.add(onWake); + return x => { + channel.wakers.delete(onWake); + return x; + }; +}); + + +const _Scheduler_rawTryRecv = (channelId) => { const channel = _Scheduler_channels.get(channelId); /**__DEBUG/ if (channel === undefined) { @@ -176,19 +194,12 @@ const _Scheduler_rawRecv = F2((channelId, onMsg) => { //*/ const msg = channel.messages.shift(); if (msg === undefined) { - const onWake = msg => { - return onMsg(msg); - } - channel.wakers.add(onWake); - return x => { - channel.wakers.delete(onWake); - return x; - }; + return __Maybe_Nothing; } else { - onMsg(msg); - return x => x; + return __Maybe_Just(msg); } -}); +}; + const _Scheduler_rawSend = F2((channelId, msg) => { const channel = _Scheduler_channels.get(channelId); diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index 94fbbb3a..87e53425 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Channel exposing (Receiver, Sender, mapSender, rawSend, rawUnbounded, recv, send, unbounded) +module Platform.Raw.Channel exposing (Receiver, Sender, Channel, mapSender, rawSend, rawUnbounded, tryRecv, recv, send, unbounded) import Basics exposing (..) import Debug @@ -17,6 +17,9 @@ type Receiver msg = Receiver +type alias Channel msg = + ( Sender msg, Receiver msg ) + {-| -} recv : (msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a recv tagger chl = @@ -26,6 +29,13 @@ recv tagger chl = ) +tryRecv : (Maybe msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a +tryRecv tagger chl = + RawTask.andThen + (\() -> tagger (rawTryRecv chl)) + (RawTask.execImpure (\() -> ())) + + {-| NON PURE! Send a message to a channel. If there are tasks waiting for a message then one @@ -57,8 +67,27 @@ unbounded () = rawRecv : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction -rawRecv = - Elm.Kernel.Scheduler.rawRecv +rawRecv receiver onMsg = + case rawTryRecv receiver of + Just msg -> + let + () = + onMsg msg + in + \() -> () + + Nothing -> + setWaker receiver onMsg + + +setWaker : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction +setWaker = + Elm.Kernel.Scheduler.setWaker + + +rawTryRecv : Receiver msg -> Maybe msg +rawTryRecv = + Elm.Kernel.Scheduler.rawTryRecv mapSender : (b -> a) -> Sender a -> Sender b diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index a31e6c21..5889c15e 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Scheduler exposing (ProcessId, UniqueId, getGuid, kill, rawSpawn, spawn) +module Platform.Raw.Scheduler exposing (ProcessId, UniqueId, batch, getGuid, kill, rawSpawn, spawn) {-| This module contains the low level logic for processes. A process is a unique id used to execute tasks. @@ -7,6 +7,7 @@ unique id used to execute tasks. import Basics exposing (..) import Debug import Elm.Kernel.Scheduler +import List import Maybe exposing (Maybe(..)) import Platform.Raw.Task as RawTask @@ -40,7 +41,7 @@ rawSpawn initTask = {-| Create a task that spawns a processes. -} -spawn : RawTask.Task a -> RawTask.Task (ProcessId) +spawn : RawTask.Task a -> RawTask.Task ProcessId spawn task = RawTask.execImpure (\() -> rawSpawn task) @@ -55,14 +56,24 @@ receive values. -} kill : ProcessId -> RawTask.Task () kill processId = - RawTask.execImpure - (\() -> - case getProcessState processId of - Running killer -> - killer () - - Ready _ -> - () + RawTask.execImpure (\() -> rawKill processId) + + +batch : List ProcessId -> RawTask.Task ProcessId +batch ids = + spawn + (RawTask.AsyncAction + (\doneCallback -> + let + () = + doneCallback (spawn (RawTask.Value ())) + in + \() -> + List.foldr + (\id () -> rawKill id) + () + ids + ) ) @@ -103,7 +114,7 @@ stepper processId process = createStateWithRoot processId root -createStateWithRoot : ProcessId -> RawTask.Task state -> ProcessState state +createStateWithRoot : ProcessId -> RawTask.Task state -> ProcessState state createStateWithRoot processId root = case root of RawTask.Value val -> @@ -125,7 +136,16 @@ createStateWithRoot processId root = ) ) - +{-| NON PURE! +-} +rawKill: ProcessId -> () +rawKill id = + case getProcessState id of + Running killer -> + killer () + + Ready _ -> + () -- Kernel function redefinitons -- From 441db6c295dffe2b25e8bb113228e782506bd550 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 2 Apr 2020 21:18:52 +0100 Subject: [PATCH 103/170] mega commit The key change is that incoming ports use a new method to send messages to the app. Along the way I moved the channel logic out of Scheduler.js and into its own function. I also created a very nifty tool for keeping kernel code in shape. Run `./tests/check-kernel-imports.js` to track the errors the compiler refuses to give an details about. The realy painful thing is that the compilers dependancy logic is broken for kernel function that call elm functions. Therefore, any kernel code that may run immedately when the js is loaded cannot call elm code. Consequently, I have been force to write more kernel code than I would otherwise have liked. On the otherhand, I do think that most of the Channel code belongs in kernel land. The kernel code will probably have to worry about syncronisation so the fact that I reduced the elm code in the Channel module is probably a good thing going forward. --- src/Elm/Kernel/Basics.js | 2 +- src/Elm/Kernel/Channel.js | 89 +++++++++++++++++ src/Elm/Kernel/Debug.js | 7 ++ src/Elm/Kernel/Platform.js | 121 ++++++++++++++++++----- src/Elm/Kernel/Scheduler.js | 70 ------------- src/Platform.elm | 98 ++++++++++++++----- src/Platform/Channel.elm | 1 - src/Platform/Raw/Channel.elm | 46 +++------ tests/check-kernel-imports.js | 179 ++++++++++++++++++++++++++++++++++ 9 files changed, 457 insertions(+), 156 deletions(-) create mode 100644 src/Elm/Kernel/Channel.js create mode 100755 tests/check-kernel-imports.js diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index fc05521e..2f08ba6b 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -30,7 +30,7 @@ const _Basics_fudgeType = x => x; const _Basics_unwrapTypeWrapper__DEBUG = wrapped => { const entries = Object.entries(wrapped); if (entries.length !== 2) { - __Debug_crash(12, 'failedUnwrap'); + __Debug_crash(12, 'failedUnwrap', wrapped); } if (entries[0][0] === '$') { return entries[1][1]; diff --git a/src/Elm/Kernel/Channel.js b/src/Elm/Kernel/Channel.js new file mode 100644 index 00000000..fad6197d --- /dev/null +++ b/src/Elm/Kernel/Channel.js @@ -0,0 +1,89 @@ +/* + +import Maybe exposing (Just, Nothing) +import Elm.Kernel.Debug exposing (crash) +import Elm.Kernel.Utils exposing (Tuple2) +*/ + +const _Channel_channels = new WeakMap(); +let _Channel_channelId = 0; + +const _Channel_rawUnbounded = _ => { + const id = { + id: _Channel_channelId++ + }; + _Channel_channels.set(id, { + messages: [], + wakers: new Set(), + }); + return __Utils_Tuple2(_Channel_rawSendImpl(id), id); +} + + +const _Channel_rawTryRecv = (channelId) => { + const channel = _Channel_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + const msg = channel.messages.shift(); + if (msg === undefined) { + return __Maybe_Nothing; + } else { + return __Maybe_Just(msg); + } +}; + + +const _Channel_rawRecv = F2((channelId, onMsg) => { + const channel = _Channel_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + const msg = channel.messages.shift(); + if (msg !== undefined) { + onMsg(msg); + return x => x; + } + const onWake = msg => { + return onMsg(msg); + } + channel.wakers.add(onWake); + return x => { + channel.wakers.delete(onWake); + return x; + }; +}); + + +const _Channel_rawSendImpl = F2((channelId, msg) => { + const channel = _Channel_channels.get(channelId); + /**__DEBUG/ + if (channel === undefined) { + __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + } + //*/ + + const wakerIter = channel.wakers[Symbol.iterator](); + const { value: nextWaker, done } = wakerIter.next(); + if (done) { + channel.messages.push(msg); + } else { + channel.wakers.delete(nextWaker); + nextWaker(msg); + } + return _Utils_Tuple0; +}); + + +const _Channel_rawSend = F2((sender, msg) => { + sender(msg); +}); + + +const _Channel_mapSender = F2((func, sender) => { + return val => sender(func(val)); +}); diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index a9295d14..cc0c8a14 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -328,6 +328,13 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) case 'procIdAlreadyReady': throw new Error(`Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared`); + + case 'subscriptionProcessMissing': + throw new Error(`Bug in elm runtime: expected there to be a subscriptionProcess with id ${fact2}.`); + + case 'failedUnwrap': + throw new Error(`Bug in elm runtime: trying to unwrap an new type but the js object had the following keys: ${Object.keys(fact2).join(', ')}`) + } throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 4a9ce248..ed5979ea 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -3,11 +3,13 @@ import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) import Elm.Kernel.List exposing (Cons, Nil) -import Elm.Kernel.Utils exposing (Tuple0) +import Elm.Kernel.Utils exposing (Tuple0, Tuple2) +import Elm.Kernel.Channel exposing (rawUnbounded, rawSend, mapSender) import Result exposing (isOk) import Platform exposing (Task, ProcessId) import Platform.Effects as Effects exposing (mapCommand) -import Platform.Scheduler as Scheduler exposing (binding, succeed) +import Platform.Scheduler as Scheduler exposing (binding, succeed, rawSpawn, andThen) +import Platform.Channel as NiceChannel exposing (recv, send) */ @@ -88,13 +90,8 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { for (const [key, {port}] of _Platform_outgoingPorts.entries()) { ports[key] = port; } - for (const [key, setup] of _Platform_incomingPorts.entries()) { - const {port, manager} = setup( - functions.__$setupIncomingPort, - sendToApp - ); + for (const [key, {port}] of _Platform_incomingPorts.entries()) { ports[key] = port; - selfSenders.set(key, manager); } const initValue = impl.__$init(flagsResult.a); @@ -260,39 +257,111 @@ function _Platform_outgoingPort(name, converter) function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - _Platform_incomingPorts.set(name, function(setup, sendToApp) { - let subs = __List_Nil; - - function updateSubs(subsList) { - subs = subsList; - } + const channel = __Channel_rawUnbounded(); - const setupTuple = A2(setup, sendToApp, updateSubs); - - function send(incomingValue) - { - var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); + function send(incomingValue) + { + var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); - __Result_isOk(result) || __Debug_crash(4, name, result.a); + __Result_isOk(result) || __Debug_crash(4, name, result.a); - var value = result.a; - A2(setupTuple.b, value, subs); - } + var value = result.a; + A2(__Channel_rawSend, channel.a, value); + } - return { + _Platform_incomingPorts.set( + name, + { port: { send, }, - manager: setupTuple.a, } + ); + + const key = _Platform_createSubProcess(sender => { + const onMsgReceive = receiver => + A2( + __Scheduler_andThen, + _ => onMsgReceive(receiver), + A2( + __NiceChannel_recv, + __NiceChannel_send(sender), + receiver + ) + ); + return onMsgReceive(channel.b); }); - return _Platform_leaf(name) + return tagger => A2( + _Platform_leaf, + '000PlatformEffect', + __Utils_Tuple2(key, tagger) + ); } // Functions exported to elm +const _Platform_subscriptionMap = new Map(); +let _Platform_subscriptionProcessIds = 0; + +const _Platform_createSubProcess = createTask => { + const channel = __Channel_rawUnbounded(); + const key = { id: _Platform_subscriptionProcessIds++ }; + const onSubEffects = receiver => + A2( + __Scheduler_andThen, + _ => onSubEffects(receiver), + A2( + __NiceChannel_recv, + t => t, + receiver, + ) + ); + + _Platform_subscriptionMap.set(key, []); + const mappedSender = A2( + __Channel_mapSender, + val => { + return __Scheduler_binding(doneCallback => { + const sendToApps = _Platform_subscriptionMap.get(key); + /**__DEBUG/ + if (sendToApps === undefined) { + __Debug_crash(12, 'subscriptionProcessMissing', key && key.id); + } + //*/ + for (const sendToApp of sendToApps) { + sendToApp(val); + } + doneCallback(__Scheduler_succeed(__Utils_Tuple0)); + return x => x; + }); + }, + channel.a, + ); + + Promise.resolve().then(() => { + __Scheduler_rawSpawn(createTask(mappedSender)); + __Scheduler_rawSpawn(onSubEffects(channel.b)); + }); + + return key; +}; + +const _Platform_resetSubscriptions = func => { + for (const sendToApps of _Platform_subscriptionMap.values()) { + sendToApps.length = 0; + } + func(F2((key, sendToApp) => { + const sendToApps = _Platform_subscriptionMap.get(key); + /**__DEBUG/ + if (sendToApps === undefined) { + __Debug_crash(12, 'subscriptionProcessMissing', key && key.id); + } + //*/ + sendToApps.push(sendToApp); + })); +}; const _Platform_effectManagerNameToString = name => name; diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index e7c16c16..106e8041 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -3,7 +3,6 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) import Maybe exposing (Just, Nothing) import Elm.Kernel.Debug exposing (crash) -import Elm.Kernel.Utils exposing (Tuple0, Tuple2) */ // COMPATIBILITY @@ -150,72 +149,3 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { return _Utils_Tuple0; }); - -// CHANNELS - -const _Scheduler_channels = new WeakMap(); -let _Scheduler_channelId = 0; - -const _Scheduler_rawUnbounded = _ => { - const id = { - id: _Scheduler_channelId++ - }; - _Scheduler_channels.set(id, { - messages: [], - wakers: new Set(), - }); - return _Utils_Tuple2(_Scheduler_rawSend(id), id); -} - -const _Scheduler_setWaker = F2((channelId, onMsg) => { - const channel = _Scheduler_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); - } - //*/ - const onWake = msg => { - return onMsg(msg); - } - channel.wakers.add(onWake); - return x => { - channel.wakers.delete(onWake); - return x; - }; -}); - - -const _Scheduler_rawTryRecv = (channelId) => { - const channel = _Scheduler_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); - } - //*/ - const msg = channel.messages.shift(); - if (msg === undefined) { - return __Maybe_Nothing; - } else { - return __Maybe_Just(msg); - } -}; - - -const _Scheduler_rawSend = F2((channelId, msg) => { - const channel = _Scheduler_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); - } - //*/ - - const wakerIter = channel.wakers[Symbol.iterator](); - const { value: nextWaker, done } = wakerIter.next(); - if (done) { - channel.messages.push(msg); - } else { - channel.wakers.delete(nextWaker); - nextWaker(msg); - } - return _Utils_Tuple0; -}); diff --git a/src/Platform.elm b/src/Platform.elm index b95d8d05..9be5c9cf 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -49,6 +49,7 @@ import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) import Tuple +import Debug @@ -129,7 +130,7 @@ information on this. It is only defined here because it is a platform primitive. -} type ProcessId - = ProcessId (RawScheduler.ProcessId) + = ProcessId RawScheduler.ProcessId @@ -185,7 +186,7 @@ app's main update cycle (i.e. the receiver will call sendToApp2). setupEffectsChannel : SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) setupEffectsChannel sendToApp2 = let - dispatchChannel : ( Channel.Sender (ReceivedData appMsg Never), Channel.Receiver (ReceivedData appMsg Never) ) + dispatchChannel : Channel.Channel (ReceivedData appMsg Never) dispatchChannel = Channel.rawUnbounded () @@ -193,22 +194,16 @@ setupEffectsChannel sendToApp2 = appChannel = Channel.rawUnbounded () - receiveMsg : ReceivedData appMsg Never -> RawTask.Task () - receiveMsg msg = - case msg of - Self value -> - never value - - App cmds subs -> - cmds - |> createPlatformEffectFuncs - |> List.map + spawnEffects : List (Channel.Sender appMsg -> Task Never ()) -> RawTask.Task (List RawScheduler.ProcessId) + spawnEffects = + List.map (\payload channel -> let (Task t) = payload channel in - RawTask.map + t + |> RawTask.map (\r -> case r of Ok val -> @@ -217,20 +212,56 @@ setupEffectsChannel sendToApp2 = Err err -> never err ) - t + |> RawScheduler.spawn + ) + >> List.foldr + (\curr accTask -> + RawTask.andThen + (\acc -> + RawTask.map + (\id -> id :: acc) + (curr (Tuple.first appChannel)) ) - |> List.foldr - (\curr prev -> - RawTask.andThen - (\() -> curr (Tuple.first appChannel)) - prev + accTask + ) + (RawTask.Value []) + + receiveMsg : ReceivedData appMsg Never -> RawTask.Task () + receiveMsg msg = + case msg of + Self value -> + never value + + App cmds subs -> + let + -- Create a task that spawns processes that + -- will never be killed. + cmdTask = + cmds + |> List.map createPlatformEffectFuncsFromCmd + |> spawnEffects + + -- Reset and re-register all subscriptions. + () = + resetSubscriptions + (\func -> + subs + |> List.map createPlatformEffectFuncsFromSub + |> List.foldr + (\( id, tagger ) () -> + func id (\v -> sendToApp2 (tagger v) AsyncUpdate) + ) + () ) - (RawTask.Value ()) + in + cmdTask + |> RawTask.map (\_ -> ()) + dispatchTask : () -> RawTask.Task () dispatchTask () = - RawTask.andThen - dispatchTask - (Channel.recv receiveMsg (Tuple.second dispatchChannel)) + Tuple.second dispatchChannel + |> Channel.recv receiveMsg + |> RawTask.andThen dispatchTask appTask () = RawTask.andThen @@ -458,6 +489,13 @@ type UpdateMetadata | AsyncUpdate +type IncomingPortId + = IncomingPortId IncomingPortId + + +type HiddenConvertedSubType + = HiddenConvertedSubType HiddenConvertedSubType + type ReceivedData appMsg selfMsg = Self selfMsg @@ -568,6 +606,16 @@ createIncomingPortConverters = Elm.Kernel.Basics.fudgeType -createPlatformEffectFuncs : List (HiddenMyCmd msg) -> List (Channel.Sender msg -> Task Never ()) -createPlatformEffectFuncs = +createPlatformEffectFuncsFromCmd : HiddenMyCmd msg -> (Channel.Sender msg -> Task Never ()) +createPlatformEffectFuncsFromCmd = Elm.Kernel.Basics.fudgeType + + +createPlatformEffectFuncsFromSub : HiddenMySub msg -> ( IncomingPortId, HiddenConvertedSubType -> msg ) +createPlatformEffectFuncsFromSub = + Elm.Kernel.Basics.fudgeType + + +resetSubscriptions : ((IncomingPortId -> (HiddenConvertedSubType -> ()) -> ()) -> ()) -> () +resetSubscriptions = + Elm.Kernel.Platform.resetSubscriptions diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm index ab2c1c53..a173d6c7 100644 --- a/src/Platform/Channel.elm +++ b/src/Platform/Channel.elm @@ -2,7 +2,6 @@ module Platform.Channel exposing (Receiver, Sender, mapSender, recv, send, unbou import Basics exposing (..) import Debug -import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) import Platform import Platform.Raw.Channel as RawChannel diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index 87e53425..dc66889c 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -2,7 +2,7 @@ module Platform.Raw.Channel exposing (Receiver, Sender, Channel, mapSender, rawS import Basics exposing (..) import Debug -import Elm.Kernel.Scheduler +import Elm.Kernel.Channel import Maybe exposing (Maybe(..)) import Platform.Raw.Scheduler as RawScheduler import Platform.Raw.Task as RawTask @@ -10,7 +10,7 @@ import Tuple type Sender msg - = Sender (msg -> ()) + = Sender type Receiver msg @@ -32,8 +32,8 @@ recv tagger chl = tryRecv : (Maybe msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a tryRecv tagger chl = RawTask.andThen - (\() -> tagger (rawTryRecv chl)) - (RawTask.execImpure (\() -> ())) + tagger + (RawTask.execImpure (\() -> rawTryRecv chl)) {-| NON PURE! @@ -44,8 +44,8 @@ message will be added to the channel's queue. -} rawSend : Sender msg -> msg -> () -rawSend (Sender sender) = - sender +rawSend = + Elm.Kernel.Channel.rawSend {-| Create a task, if run, will send a message to a channel. @@ -56,9 +56,8 @@ send channelId msg = rawUnbounded : () -> ( Sender msg, Receiver msg ) -rawUnbounded () = - Elm.Kernel.Scheduler.rawUnbounded () - |> Tuple.mapFirst Sender +rawUnbounded = + Elm.Kernel.Channel.rawUnbounded unbounded : () -> RawTask.Task ( Sender msg, Receiver msg ) @@ -67,34 +66,15 @@ unbounded () = rawRecv : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction -rawRecv receiver onMsg = - case rawTryRecv receiver of - Just msg -> - let - () = - onMsg msg - in - \() -> () - - Nothing -> - setWaker receiver onMsg - - -setWaker : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction -setWaker = - Elm.Kernel.Scheduler.setWaker +rawRecv = + Elm.Kernel.Channel.rawRecv rawTryRecv : Receiver msg -> Maybe msg rawTryRecv = - Elm.Kernel.Scheduler.rawTryRecv + Elm.Kernel.Channel.rawTryRecv mapSender : (b -> a) -> Sender a -> Sender b -mapSender fn (Sender sender) = - Sender (\b -> sender (fn b)) - - -rawUnboundedKernel : () -> ( msg -> (), Receiver msg ) -rawUnboundedKernel = - Elm.Kernel.Scheduler.rawUnbounded +mapSender = + Elm.Kernel.Channel.mapSender diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js new file mode 100755 index 00000000..81234423 --- /dev/null +++ b/tests/check-kernel-imports.js @@ -0,0 +1,179 @@ +#! /usr/bin/env node + +const path = require('path'); +const fs = require('fs'); +const readline = require('readline'); + +async function* getFiles(dir) { + const dirents = await fs.promises.readdir(dir, { withFileTypes: true }); + for (const dirent of dirents) { + const res = path.resolve(dir, dirent.name); + if (dirent.isDirectory()) { + yield* getFiles(res); + } else { + yield res; + } + } +} + +class CallLocation { + constructor(path, line) { + this.path = path; + this.line = line; + Object.freeze(this); + } +} + +async function* withLineNumbers(rl) { + let i = 1; + for await (const line of rl) { + yield { line, number: i } + i += 1; + } +} + +async function processElmFile(file, kernelCalls) { + const lines = withLineNumbers(readline.createInterface({ + input: fs.createReadStream(file) + })); + + const kernelImports = new Map(); + + const errors = []; + const warnings = []; + + for await (const {number, line} of lines) { + const importMatch = line.match(/^import\s+(Elm\.Kernel\.\w+)/u); + if (importMatch !== null) { + kernelImports.set(importMatch[1], false); + } else { + const kernelCallMatch = line.match(/(Elm\.Kernel\.\w+).\w+/u); + if (kernelCallMatch !== null) { + const kernelCall = kernelCallMatch[0]; + const kernelModule = kernelCallMatch[1]; + if (kernelImports.has(kernelModule)) { + kernelImports.set(kernelModule, true); + } else { + errors.push(`Kernel call ${kernelCall} at ${file}:${number} missing import`); + } + (() => { + if (!kernelCalls.has(kernelCall)) { + const a = []; + kernelCalls.set(kernelCall, a); + return a; + } + return kernelCalls.get(kernelCall); + })().push(new CallLocation(file, number)); + } + } + } + + for (const [kernelModule, used] of kernelImports.entries()) { + if (!used) { + warnings.push(`Kernel import of ${kernelModule} is unused in ${file}`); + } + } + + return { errors, warnings }; +} + +async function processJsFile(file, kernelDefinitions) { + const lines = withLineNumbers(readline.createInterface({ + input: fs.createReadStream(file) + })); + + const moduleName = path.basename(file, '.js'); + + const imports = new Map(); + + const errors = []; + const warnings = []; + + for await (const {number, line} of lines) { + + const importMatch = line.match(/import\s+(?:(?:\w|\.)+\.)?(\w+)\s+(?:as (\w+)\s+)?exposing\s+\((\w+(?:,\s+\w+)*)\)/); + if (importMatch !== null) { + // use alias if it is there, otherwise use last part of import. + let moduleAlias = importMatch[2] !== undefined ? importMatch[2] : importMatch[1]; + for (const defName of importMatch[3].split(',').map(s => s.trim())) { + imports.set(`__${moduleAlias}_${defName}`, false); + } + continue; + } + + let defMatch = line.match(/^(?:var|const|let)\s*(_(\w+?)_(\w+))\s*=/u); + if (defMatch === null) { + defMatch = line.match(/^function\s*(_(\w+?)_(\w+))\s*\(/u); + } + if (defMatch !== null) { + if (defMatch[2] !== moduleName) { + errors.push(`Kernel definition ${defMatch[1]} at ${file}:${number} should match _${moduleName}_*`); + } + let defName = defMatch[3]; + if (defName.endsWith('__DEBUG')) { + defName = defName.substr(0, defName.length - '__DEBUG'.length); + } else if (defName.endsWith('__PROD')) { + defName = defName.substr(0, defName.length - '__PROD'.length); + } + // todo(Harry): check __DEBUG and __PROD match. + + kernelDefinitions.add(`Elm.Kernel.${moduleName}.${defName}`); + continue; + } + + const kernelCallMatch = line.match(/__\w+_\w+/u); + if (kernelCallMatch !== null) { + const kernelCall = kernelCallMatch[0]; + if (imports.has(kernelCall)) { + imports.set(kernelCall, true); + } else { + errors.push(`Kernel call ${kernelCall} at ${file}:${number} missing import`); + } + } + + } + + for (const [kernelModule, used] of imports.entries()) { + if (!used) { + warnings.push(`Import of ${kernelModule} is unused in ${file}`); + } + } + + return {errors, warnings}; +} + +(async () => { + // keys: kernel definition full elm path + const kernelDefinitions = new Set(); + // keys: kernel call, values: array of CallLocations + const kernelCalls = new Map(); + + const allErrors = []; + const allWarnings = []; + + for await (const f of getFiles(process.argv[2])) { + const extname = path.extname(f); + if (extname === '.elm') { + const { errors, warnings } = await processElmFile(f, kernelCalls); + allErrors.push(...errors); + allWarnings.push(...warnings); + } else if (extname === '.js') { + const { errors, warnings } = await processJsFile(f, kernelDefinitions); + allErrors.push(...errors); + allWarnings.push(...warnings); + } + } + for (const [call, locations] of kernelCalls.entries()) { + if (!kernelDefinitions.has(call)) { + for (const location of locations) { + allErrors.push(`Kernel call ${call} at ${location.path}:${location.line} missing definition`); + } + } + } + console.error(`${allWarnings.length} warnings`); + console.error(allWarnings.join('\n')); + console.error(''); + console.error(`${allErrors.length} errors`) + console.error(allErrors.join('\n')); + process.exitCode = allErrors.length === 0 ? 0 : 1; +})() From 5f4dafe98a7263f2ba0e4e8fae32eb288c25a8a8 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 2 Apr 2020 22:41:08 +0100 Subject: [PATCH 104/170] use tasks instead of channels for commands --- src/Elm/Kernel/Platform.js | 5 ++-- src/Platform.elm | 49 +++++++++++++++-------------------- src/Platform/Effects.elm | 10 +++---- src/Task.elm | 8 +----- tests/check-kernel-imports.js | 18 ++++++++----- 5 files changed, 42 insertions(+), 48 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index ed5979ea..25dedaa2 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -6,6 +6,7 @@ import Elm.Kernel.List exposing (Cons, Nil) import Elm.Kernel.Utils exposing (Tuple0, Tuple2) import Elm.Kernel.Channel exposing (rawUnbounded, rawSend, mapSender) import Result exposing (isOk) +import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId) import Platform.Effects as Effects exposing (mapCommand) import Platform.Scheduler as Scheduler exposing (binding, succeed, rawSpawn, andThen) @@ -245,9 +246,9 @@ function _Platform_outgoingPort(name, converter) return payload => A2( _Platform_leaf, '000PlatformEffect', - _ => __Scheduler_binding(doneCallback => { + __Scheduler_binding(doneCallback => { execSubscribers(payload); - doneCallback(__Scheduler_succeed(__Utils_Tuple0)); + doneCallback(__Scheduler_succeed(__Maybe_Nothing)); return x => x; }) ); diff --git a/src/Platform.elm b/src/Platform.elm index 9be5c9cf..712ba36e 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -49,7 +49,6 @@ import Platform.Sub exposing (Sub) import Result exposing (Result(..)) import String exposing (String) import Tuple -import Debug @@ -194,37 +193,38 @@ setupEffectsChannel sendToApp2 = appChannel = Channel.rawUnbounded () - spawnEffects : List (Channel.Sender appMsg -> Task Never ()) -> RawTask.Task (List RawScheduler.ProcessId) - spawnEffects = + runCmds : List (Task Never (Maybe appMsg)) -> RawTask.Task RawScheduler.ProcessId + runCmds = List.map - (\payload channel -> - let - (Task t) = - payload channel - in + (\(Task t) -> t |> RawTask.map - (\r -> - case r of - Ok val -> - val - - Err err -> - never err - ) - |> RawScheduler.spawn + (\r -> + case r of + Ok (Just msg) -> + sendToApp2 msg AsyncUpdate + + Ok Nothing -> + () + + Err err -> + never err ) + |> RawScheduler.spawn + ) >> List.foldr (\curr accTask -> RawTask.andThen (\acc -> RawTask.map (\id -> id :: acc) - (curr (Tuple.first appChannel)) + curr ) accTask ) (RawTask.Value []) + >> RawTask.andThen (RawScheduler.batch) + receiveMsg : ReceivedData appMsg Never -> RawTask.Task () receiveMsg msg = @@ -239,7 +239,7 @@ setupEffectsChannel sendToApp2 = cmdTask = cmds |> List.map createPlatformEffectFuncsFromCmd - |> spawnEffects + |> runCmds -- Reset and re-register all subscriptions. () = @@ -252,7 +252,7 @@ setupEffectsChannel sendToApp2 = func id (\v -> sendToApp2 (tagger v) AsyncUpdate) ) () - ) + ) in cmdTask |> RawTask.map (\_ -> ()) @@ -263,16 +263,9 @@ setupEffectsChannel sendToApp2 = |> Channel.recv receiveMsg |> RawTask.andThen dispatchTask - appTask () = - RawTask.andThen - appTask - (Channel.recv (\msg -> RawTask.Value (sendToApp2 msg AsyncUpdate)) (Tuple.second appChannel)) _ = RawScheduler.rawSpawn (RawTask.andThen dispatchTask (RawTask.sleep 0)) - - _ = - RawScheduler.rawSpawn (RawTask.andThen appTask (RawTask.sleep 0)) in Tuple.first dispatchChannel @@ -606,7 +599,7 @@ createIncomingPortConverters = Elm.Kernel.Basics.fudgeType -createPlatformEffectFuncsFromCmd : HiddenMyCmd msg -> (Channel.Sender msg -> Task Never ()) +createPlatformEffectFuncsFromCmd : HiddenMyCmd msg -> Task Never (Maybe msg) createPlatformEffectFuncsFromCmd = Elm.Kernel.Basics.fudgeType diff --git a/src/Platform/Effects.elm b/src/Platform/Effects.elm index d5e9bd44..4b460c66 100644 --- a/src/Platform/Effects.elm +++ b/src/Platform/Effects.elm @@ -5,15 +5,15 @@ import Debug import Elm.Kernel.Platform import Maybe exposing (Maybe(..)) import Platform -import Platform.Channel as Channel +import Platform.Scheduler as Scheduler import Platform.Cmd as Cmd exposing (Cmd) -command : (Channel.Sender msg -> Platform.Task Never ()) -> Cmd msg +command : Platform.Task Never (Maybe msg) -> Cmd msg command function = Elm.Kernel.Platform.leaf "000PlatformEffect" function -mapCommand : (a -> b) -> (Channel.Sender a -> Platform.Task Never ()) -> (Channel.Sender b -> Platform.Task Never ()) -mapCommand tagger function = - \channel -> function (Channel.mapSender tagger channel) +mapCommand : (a -> b) -> Platform.Task Never (Maybe a) -> Platform.Task Never (Maybe b) +mapCommand tagger task = + Scheduler.andThen ((Maybe.map tagger) >> Scheduler.succeed) task diff --git a/src/Task.elm b/src/Task.elm index cb5f5a09..139fcf29 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -380,10 +380,4 @@ attempt resultToMessage task = performHelp : Task Never msg -> Cmd msg performHelp task = - Platform.Effects.command - (\toAppSender -> - task - |> andThen (\msg -> Platform.Channel.send toAppSender msg) - |> Scheduler.spawn - |> map (\_ -> ()) - ) + Platform.Effects.command (map Just task) diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js index 81234423..e57933c7 100755 --- a/tests/check-kernel-imports.js +++ b/tests/check-kernel-imports.js @@ -121,13 +121,19 @@ async function processJsFile(file, kernelDefinitions) { continue; } - const kernelCallMatch = line.match(/__\w+_\w+/u); - if (kernelCallMatch !== null) { - const kernelCall = kernelCallMatch[0]; - if (imports.has(kernelCall)) { - imports.set(kernelCall, true); + let index = 0; + while (true) { + const kernelCallMatch = line.substr(index).match(/__\w+_\w+/u); + if (kernelCallMatch === null) { + break; } else { - errors.push(`Kernel call ${kernelCall} at ${file}:${number} missing import`); + const kernelCall = kernelCallMatch[0]; + if (imports.has(kernelCall)) { + imports.set(kernelCall, true); + } else { + errors.push(`Kernel call ${kernelCall} at ${file}:${number} missing import`); + } + index += kernelCallMatch.index + kernelCallMatch[0].length; } } From d0bbf2c1c419bcff96027aa8eb619a2fe188dafb Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 2 Apr 2020 22:42:26 +0100 Subject: [PATCH 105/170] format --- src/Basics.elm | 17 ++++++++++------- src/Platform.elm | 4 +--- src/Platform/Effects.elm | 4 ++-- src/Platform/Raw/Channel.elm | 3 ++- src/Platform/Raw/Scheduler.elm | 5 ++++- src/Platform/Scheduler.elm | 2 +- 6 files changed, 20 insertions(+), 15 deletions(-) diff --git a/src/Basics.elm b/src/Basics.elm index 5f208799..f6c3f511 100644 --- a/src/Basics.elm +++ b/src/Basics.elm @@ -569,14 +569,17 @@ compare : comparable -> comparable -> Order compare x y = let compared : Int - compared = Elm.Kernel.Utils.compare x y + compared = + Elm.Kernel.Utils.compare x y in - if lt compared 0 then - LT - else if eq compared 0 then - EQ - else - GT + if lt compared 0 then + LT + + else if eq compared 0 then + EQ + + else + GT {-| Represents the relative ordering of two things. diff --git a/src/Platform.elm b/src/Platform.elm index 712ba36e..9948e8df 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -223,8 +223,7 @@ setupEffectsChannel sendToApp2 = accTask ) (RawTask.Value []) - >> RawTask.andThen (RawScheduler.batch) - + >> RawTask.andThen RawScheduler.batch receiveMsg : ReceivedData appMsg Never -> RawTask.Task () receiveMsg msg = @@ -263,7 +262,6 @@ setupEffectsChannel sendToApp2 = |> Channel.recv receiveMsg |> RawTask.andThen dispatchTask - _ = RawScheduler.rawSpawn (RawTask.andThen dispatchTask (RawTask.sleep 0)) in diff --git a/src/Platform/Effects.elm b/src/Platform/Effects.elm index 4b460c66..ae4d76a6 100644 --- a/src/Platform/Effects.elm +++ b/src/Platform/Effects.elm @@ -5,8 +5,8 @@ import Debug import Elm.Kernel.Platform import Maybe exposing (Maybe(..)) import Platform -import Platform.Scheduler as Scheduler import Platform.Cmd as Cmd exposing (Cmd) +import Platform.Scheduler as Scheduler command : Platform.Task Never (Maybe msg) -> Cmd msg @@ -16,4 +16,4 @@ command function = mapCommand : (a -> b) -> Platform.Task Never (Maybe a) -> Platform.Task Never (Maybe b) mapCommand tagger task = - Scheduler.andThen ((Maybe.map tagger) >> Scheduler.succeed) task + Scheduler.andThen (Maybe.map tagger >> Scheduler.succeed) task diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index dc66889c..81c5ce7f 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Channel exposing (Receiver, Sender, Channel, mapSender, rawSend, rawUnbounded, tryRecv, recv, send, unbounded) +module Platform.Raw.Channel exposing (Channel, Receiver, Sender, mapSender, rawSend, rawUnbounded, recv, send, tryRecv, unbounded) import Basics exposing (..) import Debug @@ -20,6 +20,7 @@ type Receiver msg type alias Channel msg = ( Sender msg, Receiver msg ) + {-| -} recv : (msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a recv tagger chl = diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index 5889c15e..9842de95 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -136,9 +136,10 @@ createStateWithRoot processId root = ) ) + {-| NON PURE! -} -rawKill: ProcessId -> () +rawKill : ProcessId -> () rawKill id = case getProcessState id of Running killer -> @@ -147,6 +148,8 @@ rawKill id = Ready _ -> () + + -- Kernel function redefinitons -- diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 49f27fa2..98e8e3bc 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed, wrapTask, unwrapTask) +module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed, unwrapTask, wrapTask) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. From b911a706a29946c9a049bb8df0c8d235856ed576 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 4 Apr 2020 18:03:08 +0100 Subject: [PATCH 106/170] add help information --- tests/check-kernel-imports.js | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js index e57933c7..de846abf 100755 --- a/tests/check-kernel-imports.js +++ b/tests/check-kernel-imports.js @@ -148,7 +148,33 @@ async function processJsFile(file, kernelDefinitions) { return {errors, warnings}; } -(async () => { +async function main() { + if (process.argv.length !== 3) { + console.error('check-kernel-imports: error! path to source directories required'); + process.exit(1); + } + + if (process.argv.includes('-h') || process.argv.includes('--help')) { + console.log(` + +Usage: check-kernel-imports SOURCE_DIRECTORY + +check-kernel-imports checks that + 1. Use of kernel definitions match imports in elm files. + 2. Use of kernel definition in elm files match a definition in a javascipt file. + 3. Use of an external definition matches an import in a javascript file. +Additionally, warnings will be issued for unused imports in javascript files. + +Options: + -h, --help display this help and exit + + `.trim()) + process.exit(0); + } + + const sourceDir = process.argv[2]; + + // keys: kernel definition full elm path const kernelDefinitions = new Set(); // keys: kernel call, values: array of CallLocations @@ -157,7 +183,7 @@ async function processJsFile(file, kernelDefinitions) { const allErrors = []; const allWarnings = []; - for await (const f of getFiles(process.argv[2])) { + for await (const f of getFiles(sourceDir)) { const extname = path.extname(f); if (extname === '.elm') { const { errors, warnings } = await processElmFile(f, kernelCalls); @@ -182,4 +208,6 @@ async function processJsFile(file, kernelDefinitions) { console.error(`${allErrors.length} errors`) console.error(allErrors.join('\n')); process.exitCode = allErrors.length === 0 ? 0 : 1; -})() +} + +main(); From 2b15d4d2f89add660ce24116e58e7509ca4e5329 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 5 Apr 2020 16:14:20 +0100 Subject: [PATCH 107/170] fail fast on unknown runtime crash reason --- src/Elm/Kernel/Basics.js | 4 +- src/Elm/Kernel/Channel.js | 8 ++-- src/Elm/Kernel/Debug.js | 92 ++++++++++++++++++++++++------------- src/Elm/Kernel/Platform.js | 10 ++-- src/Elm/Kernel/Scheduler.js | 12 ++--- 5 files changed, 77 insertions(+), 49 deletions(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 2f08ba6b..e67f92ad 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -1,6 +1,6 @@ /* -import Elm.Kernel.Debug exposing (crash) +import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) */ @@ -30,7 +30,7 @@ const _Basics_fudgeType = x => x; const _Basics_unwrapTypeWrapper__DEBUG = wrapped => { const entries = Object.entries(wrapped); if (entries.length !== 2) { - __Debug_crash(12, 'failedUnwrap', wrapped); + __Debug_crash(12, __Debug_runtimeCrashReason('failedUnwrap'), wrapped); } if (entries[0][0] === '$') { return entries[1][1]; diff --git a/src/Elm/Kernel/Channel.js b/src/Elm/Kernel/Channel.js index fad6197d..b8e2c6ab 100644 --- a/src/Elm/Kernel/Channel.js +++ b/src/Elm/Kernel/Channel.js @@ -1,7 +1,7 @@ /* import Maybe exposing (Just, Nothing) -import Elm.Kernel.Debug exposing (crash) +import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Utils exposing (Tuple2) */ @@ -24,7 +24,7 @@ const _Channel_rawTryRecv = (channelId) => { const channel = _Channel_channels.get(channelId); /**__DEBUG/ if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); } //*/ const msg = channel.messages.shift(); @@ -40,7 +40,7 @@ const _Channel_rawRecv = F2((channelId, onMsg) => { const channel = _Channel_channels.get(channelId); /**__DEBUG/ if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); } //*/ const msg = channel.messages.shift(); @@ -63,7 +63,7 @@ const _Channel_rawSendImpl = F2((channelId, msg) => { const channel = _Channel_channels.get(channelId); /**__DEBUG/ if (channel === undefined) { - __Debug_crash(12, 'channelIdNotRegistered', channelId && channelId.a && channelId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); } //*/ diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index cc0c8a14..cca49340 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -230,6 +230,65 @@ function _Debug_toHexDigit(n) // CRASH +function _Debug_runtimeCrashReason__PROD(reason) {} + + +function _Debug_runtimeCrashReason__DEBUG(reason) { + switch (reason) { + case 'subMap': + return function(fact2, fact3, fact4) { + throw new Error('Bug in elm runtime: attempting to subMap an effect from a command only effect module.'); + }; + + case 'cmdMap': + return function(fact2, fact3, fact4) { + throw new Error('Bug in elm runtime: attempting to cmdMap an effect from a subscription only effect module.'); + }; + + case 'procIdAlreadyRegistered': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); + }; + + case 'procIdNotRegistered': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: state for process ${fact2} been has not registered!`); + }; + + case 'cannotBeStepped': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!`); + }; + + case 'reentrantProcUpdate': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: Elm.Kernel.Scheduler.updateProcessState was called from within the update function!`); + }; + + case 'earlyMsg': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: an event manager received a message before it was ready.`); + }; + + case 'procIdAlreadyReady': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared`); + }; + + case 'subscriptionProcessMissing': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: expected there to be a subscriptionProcess with id ${fact2}.`); + }; + + case 'failedUnwrap': + return function(fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: trying to unwrap an new type but the js object had the following keys: ${Object.keys(fact2).join(', ')}`); + }; + } + throw new Error(`Unknown reason for runtime crash: ${fact1}!`); +} + + function _Debug_crash__PROD(identifier) { throw new Error('https://github.com/elm/core/blob/1.0.0/hints/' + identifier + '.md'); @@ -304,38 +363,7 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) case 12: { - switch (fact1) { - case 'subMap': - throw new Error('Bug in elm runtime: attempting to subMap an effect from a command only effect module.'); - - case 'cmdMap': - throw new Error('Bug in elm runtime: attempting to cmdMap an effect from a subscription only effect module.'); - - case 'procIdAlreadyRegistered': - throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); - - case 'procIdNotRegistered': - throw new Error(`Bug in elm runtime: state for process ${fact2} been has not registered!`); - - case 'cannotBeStepped': - throw new Error(`Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!`); - - case 'reentrantProcUpdate': - throw new Error(`Bug in elm runtime: Elm.Kernel.Scheduler.updateProcessState was called from within the update function!`); - - case 'earlyMsg': - throw new Error(`Bug in elm runtime: an event manager received a message before it was ready.`); - - case 'procIdAlreadyReady': - throw new Error(`Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared`); - - case 'subscriptionProcessMissing': - throw new Error(`Bug in elm runtime: expected there to be a subscriptionProcess with id ${fact2}.`); - - case 'failedUnwrap': - throw new Error(`Bug in elm runtime: trying to unwrap an new type but the js object had the following keys: ${Object.keys(fact2).join(', ')}`) - - } + fact1(fact2, fact3, fact4); throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); } } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 25dedaa2..dfade443 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -1,6 +1,6 @@ /* -import Elm.Kernel.Debug exposing (crash) +import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) import Elm.Kernel.List exposing (Cons, Nil) import Elm.Kernel.Utils exposing (Tuple0, Tuple2) @@ -146,7 +146,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) if (typeof cmdMap !== 'function') { // Subscription only effect module return { - __cmdMapper: F2((_1, _2) => __Debug_crash(12, 'cmdMap')), + __cmdMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason('cmdMap'))), __subMapper: subMap, __init: init, __fullOnEffects: F4(function(router, _cmds, subs, state) { @@ -158,7 +158,7 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) // Command only effect module return { __cmdMapper: cmdMap, - __subMapper: F2((_1, _2) => __Debug_crash(12, 'subMap')), + __subMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason('subMap'))), __init: init, __fullOnEffects: F4(function(router, cmds, _subs, state) { return A3(onEffects, router, cmds, state); @@ -328,7 +328,7 @@ const _Platform_createSubProcess = createTask => { const sendToApps = _Platform_subscriptionMap.get(key); /**__DEBUG/ if (sendToApps === undefined) { - __Debug_crash(12, 'subscriptionProcessMissing', key && key.id); + __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); } //*/ for (const sendToApp of sendToApps) { @@ -357,7 +357,7 @@ const _Platform_resetSubscriptions = func => { const sendToApps = _Platform_subscriptionMap.get(key); /**__DEBUG/ if (sendToApps === undefined) { - __Debug_crash(12, 'subscriptionProcessMissing', key && key.id); + __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); } //*/ sendToApps.push(sendToApp); diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 106e8041..b951e4dc 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -2,7 +2,7 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) import Maybe exposing (Just, Nothing) -import Elm.Kernel.Debug exposing (crash) +import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) */ // COMPATIBILITY @@ -49,7 +49,7 @@ function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered', id && id.a && id.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('procIdNotRegistered'), id && id.a && id.a.__$id); } //*/ return procState; @@ -59,7 +59,7 @@ function _Scheduler_getProcessState(id) { var _Scheduler_registerNewProcess = F2((procId, procState) => { /**__DEBUG/ if (_Scheduler_processes.has(procId)) { - __Debug_crash(12, 'procIdAlreadyRegistered', procId && procId.a && procId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('procIdAlreadyRegistered'), procId && procId.a && procId.a.__$id); } //*/ _Scheduler_processes.set(procId, procState); @@ -76,13 +76,13 @@ const _Scheduler_enqueueWithStepper = stepper => { const procState = _Scheduler_processes.get(newProcId); /**__DEBUG/ if (procState === undefined) { - __Debug_crash(12, 'procIdNotRegistered', newProcId && newProcId.a && newProcId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('procIdNotRegistered'), newProcId && newProcId.a && newProcId.a.__$id); } //*/ const updatedState = A2(stepper, newProcId, procState); /**__DEBUG/ if (procState !== _Scheduler_processes.get(newProcId)) { - __Debug_crash(12, 'reentrantProcUpdate', newProcId && newProcId.a && newProcId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('reentrantProcUpdate'), newProcId && newProcId.a && newProcId.a.__$id); } //*/ _Scheduler_processes.set(newProcId, updatedState); @@ -91,7 +91,7 @@ const _Scheduler_enqueueWithStepper = stepper => { return procId => { /**__DEBUG/ if (queue.some(p => p.a.__$id === procId.a.__$id)) { - __Debug_crash(12, 'procIdAlreadyInQueue', procId && procId.a && procId.a.__$id); + __Debug_crash(12, __Debug_runtimeCrashReason('procIdAlreadyInQueue'), procId && procId.a && procId.a.__$id); } //*/ queue.push(procId); From cbe5d645f39799e702a28d6348354a873fd85c2b Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 5 Apr 2020 16:15:35 +0100 Subject: [PATCH 108/170] fix crash in scheduler --- src/Elm/Kernel/Scheduler.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index b951e4dc..e1552161 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -139,7 +139,7 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { if (_Scheduler_readyFlgs.has(procId)) { __Debug_crash( 12, - 'procIdAlreadyReady', + __Debug_runtimeCrashReason('procIdAlreadyReady'), procId && procId.a && procId.a.__$id, _Scheduler_readyFlgs.get(procId) ); From 29abc4ce29822aee70cf4b312b181f7e5d1c8bac Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 5 Apr 2020 16:16:20 +0100 Subject: [PATCH 109/170] remove unused runtime crash reasons --- src/Elm/Kernel/Debug.js | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index cca49340..16023b18 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -260,16 +260,6 @@ function _Debug_runtimeCrashReason__DEBUG(reason) { throw new Error(`Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!`); }; - case 'reentrantProcUpdate': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: Elm.Kernel.Scheduler.updateProcessState was called from within the update function!`); - }; - - case 'earlyMsg': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: an event manager received a message before it was ready.`); - }; - case 'procIdAlreadyReady': return function(fact2, fact3, fact4) { throw new Error(`Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared`); From 5cd7c5341d098c8f2fb6315ec2820b11f2e3aa95 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 5 Apr 2020 16:45:10 +0100 Subject: [PATCH 110/170] use runtime elm code from js w/o passing it as arg This might make it possible to fix Browser.element etc --- src/Elm/Kernel/Platform.js | 12 ++-- src/Platform.elm | 111 ++++++++++++++++++++----------------- 2 files changed, 66 insertions(+), 57 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index dfade443..70b5767f 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -7,7 +7,7 @@ import Elm.Kernel.Utils exposing (Tuple0, Tuple2) import Elm.Kernel.Channel exposing (rawUnbounded, rawSend, mapSender) import Result exposing (isOk) import Maybe exposing (Nothing) -import Platform exposing (Task, ProcessId) +import Platform exposing (Task, ProcessId, initializeHelperFunctions) import Platform.Effects as Effects exposing (mapCommand) import Platform.Scheduler as Scheduler exposing (binding, succeed, rawSpawn, andThen) import Platform.Channel as NiceChannel exposing (recv, send) @@ -25,7 +25,7 @@ var _Platform_effectDispatchInProgress = false; // INITIALIZE A PROGRAM -const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { +const _Platform_initialize = F3((flagDecoder, args, impl) => { // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a @@ -60,7 +60,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { return; } const dispatcher = A2( - functions.__$dispatchEffects, + __Platform_initializeHelperFunctions.__$dispatchEffects, fx.__cmds, fx.__subs, ); @@ -77,10 +77,10 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { dispatch(model, updateValue.b); }); - selfSenders.set('000PlatformEffect', functions.__$setupEffectsChannel(sendToApp)); + selfSenders.set('000PlatformEffect', __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp)); for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { const manager = A4( - functions.__$setupEffects, + __Platform_initializeHelperFunctions.__$setupEffects, sendToApp, effectManagerFunctions.__init, effectManagerFunctions.__fullOnEffects, @@ -97,7 +97,7 @@ const _Platform_initialize = F4((flagDecoder, args, impl, functions) => { const initValue = impl.__$init(flagsResult.a); let model = initValue.a; - const stepper = A2(functions.__$stepperBuilder, sendToApp, model); + const stepper = A2(__Platform_initializeHelperFunctions.__$stepperBuilder, sendToApp, model); dispatch(model, initValue.b); diff --git a/src/Platform.elm b/src/Platform.elm index 9948e8df..9fc208ab 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -52,6 +52,47 @@ import Tuple +-- DEFINTIONS TO BE USED BY KERNEL CODE + + +{-| Kernel code relies on this this type alias. Must be kept consistant with +code in Elm/Kernel/Platform.js. +-} +type alias InitializeHelperFunctions model appMsg = + { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg + , setupIncomingPort : + SendToApp appMsg + -> (List (HiddenMySub appMsg) -> ()) + -> ( Channel.Sender (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) + , setupEffectsChannel : + SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) + , setupEffects : + SendToApp appMsg + -> Task Never HiddenState + -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) + -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) + -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) + , dispatchEffects : + Cmd appMsg + -> Sub appMsg + -> Bag.EffectManagerName + -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) + -> () + } + + +{-| Kernel code relies on this definition existing and on the behaviour of these functions. +-} +initializeHelperFunctions = + { stepperBuilder = \_ _ -> \_ _ -> () + , setupIncomingPort = setupIncomingPort + , setupEffects = setupEffects + , dispatchEffects = dispatchEffects + , setupEffectsChannel = setupEffectsChannel + } + + + -- PROGRAMS @@ -60,11 +101,16 @@ show anything on screen? Etc. -} type Program flags model msg = Program - (Decoder flags - -> DebugMetadata - -> RawJsObject - -> RawJsObject - ) + + +{-| This is the actual type of a Program. This is the value that will be called +by javascript so it **must** be this type. +-} +type alias ActualProgram flags = + Decoder flags + -> DebugMetadata + -> RawJsObject + -> RawJsObject {-| Create a [headless] program with no user interface. @@ -95,20 +141,12 @@ worker : } -> Program flags model msg worker impl = - makeProgramCallable - (Program - (\flagsDecoder _ args -> - initialize - flagsDecoder - args - impl - { stepperBuilder = \_ _ -> \_ _ -> () - , setupIncomingPort = setupIncomingPort - , setupEffects = setupEffects - , dispatchEffects = dispatchEffects - , setupEffectsChannel = setupEffectsChannel - } - ) + makeProgram + (\flagsDecoder _ args -> + initialize + flagsDecoder + args + impl ) @@ -520,29 +558,6 @@ type alias Impl flags model msg = } -type alias InitFunctions model appMsg = - { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupIncomingPort : - SendToApp appMsg - -> (List (HiddenMySub appMsg) -> ()) - -> ( Channel.Sender (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) - , setupEffectsChannel : - SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) - , setupEffects : - SendToApp appMsg - -> Task Never HiddenState - -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) - -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) - , dispatchEffects : - Cmd appMsg - -> Sub appMsg - -> Bag.EffectManagerName - -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) - -> () - } - - -- kernel -- @@ -551,15 +566,14 @@ initialize : Decoder flags -> RawJsObject -> Impl flags model msg - -> InitFunctions model msg -> RawJsObject initialize = Elm.Kernel.Platform.initialize -makeProgramCallable : Program flags model msg -> Program flags model msg -makeProgramCallable (Program program) = - Elm.Kernel.Basics.fudgeType program +makeProgram : ActualProgram flags -> Program flags model msg +makeProgram = + Elm.Kernel.Basics.fudgeType effectManagerNameToString : Bag.EffectManagerName -> String @@ -587,11 +601,6 @@ createHiddenMySubList = Elm.Kernel.Basics.fudgeType -createValuesToSendOutOfPorts : List (HiddenMyCmd Never) -> List Encode.Value -createValuesToSendOutOfPorts = - Elm.Kernel.Basics.fudgeType - - createIncomingPortConverters : List (HiddenMySub msg) -> List (Encode.Value -> msg) createIncomingPortConverters = Elm.Kernel.Basics.fudgeType From 4d9145823994f1d7679987ade4de47c543012081 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 5 Apr 2020 16:45:50 +0100 Subject: [PATCH 111/170] remove kernel function not calling elm code rule --- README.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/README.md b/README.md index b396982c..8ca95f78 100644 --- a/README.md +++ b/README.md @@ -11,6 +11,4 @@ ## Rules * Each kernel function may only be called via a type annotated redefinition in an elm file. -* Kernel functions may **not** call globally defined elm functions. - Elm functions _can_ be passed into kernel functions as arguments. * Kernel functions may **not** call other kernel functions. From bab8e4c2c3e76b6564a85637893ce7b0c173c63f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 22:15:32 +0100 Subject: [PATCH 112/170] tidy some Channel things --- src/Platform.elm | 45 ++++++++++++++++++++------------------------- src/Task.elm | 1 - 2 files changed, 20 insertions(+), 26 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 9fc208ab..2c7a737b 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -227,29 +227,24 @@ setupEffectsChannel sendToApp2 = dispatchChannel = Channel.rawUnbounded () - appChannel : ( Channel.Sender appMsg, Channel.Receiver appMsg ) - appChannel = - Channel.rawUnbounded () - runCmds : List (Task Never (Maybe appMsg)) -> RawTask.Task RawScheduler.ProcessId runCmds = - List.map - (\(Task t) -> - t - |> RawTask.map - (\r -> - case r of - Ok (Just msg) -> - sendToApp2 msg AsyncUpdate - - Ok Nothing -> - () - - Err err -> - never err - ) - |> RawScheduler.spawn - ) + List.map (\(Task t) -> t) + >> List.map + (RawTask.map + (\r -> + case r of + Ok (Just msg) -> + sendToApp2 msg AsyncUpdate + + Ok Nothing -> + () + + Err err -> + never err + ) + ) + >> List.map RawScheduler.spawn >> List.foldr (\curr accTask -> RawTask.andThen @@ -271,8 +266,6 @@ setupEffectsChannel sendToApp2 = App cmds subs -> let - -- Create a task that spawns processes that - -- will never be killed. cmdTask = cmds |> List.map createPlatformEffectFuncsFromCmd @@ -281,12 +274,14 @@ setupEffectsChannel sendToApp2 = -- Reset and re-register all subscriptions. () = resetSubscriptions - (\func -> + (\addSubscription -> subs |> List.map createPlatformEffectFuncsFromSub |> List.foldr (\( id, tagger ) () -> - func id (\v -> sendToApp2 (tagger v) AsyncUpdate) + addSubscription + id + (\v -> sendToApp2 (tagger v) AsyncUpdate) ) () ) diff --git a/src/Task.elm b/src/Task.elm index 139fcf29..849ed9c5 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -34,7 +34,6 @@ import Basics exposing ((<<), (|>), Never, never) import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform -import Platform.Channel import Platform.Cmd exposing (Cmd) import Platform.Effects import Platform.Scheduler as Scheduler From e9dc91018888dc19de796575d777cee4ffd77604 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 22:34:45 +0100 Subject: [PATCH 113/170] definition lines can also contain kernel calls! --- tests/check-kernel-imports.js | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js index de846abf..88432b5e 100755 --- a/tests/check-kernel-imports.js +++ b/tests/check-kernel-imports.js @@ -118,7 +118,6 @@ async function processJsFile(file, kernelDefinitions) { // todo(Harry): check __DEBUG and __PROD match. kernelDefinitions.add(`Elm.Kernel.${moduleName}.${defName}`); - continue; } let index = 0; From 9305022526bc6866f377d17b0e3ecd31533c06d6 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 22:35:59 +0100 Subject: [PATCH 114/170] tidy resetSubscription kernel api --- src/Elm/Kernel/Platform.js | 11 +++++++---- src/Platform.elm | 18 +++++++----------- 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 70b5767f..71ba80a9 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -2,7 +2,7 @@ import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) -import Elm.Kernel.List exposing (Cons, Nil) +import Elm.Kernel.List exposing (Cons, Nil, toArray) import Elm.Kernel.Utils exposing (Tuple0, Tuple2) import Elm.Kernel.Channel exposing (rawUnbounded, rawSend, mapSender) import Result exposing (isOk) @@ -349,11 +349,13 @@ const _Platform_createSubProcess = createTask => { return key; }; -const _Platform_resetSubscriptions = func => { +const _Platform_resetSubscriptions = newSubs => { for (const sendToApps of _Platform_subscriptionMap.values()) { sendToApps.length = 0; } - func(F2((key, sendToApp) => { + for (const tuple of __List_toArray(newSubs)) { + const key = tuple.a; + const sendToApp = tuple.b; const sendToApps = _Platform_subscriptionMap.get(key); /**__DEBUG/ if (sendToApps === undefined) { @@ -361,7 +363,8 @@ const _Platform_resetSubscriptions = func => { } //*/ sendToApps.push(sendToApp); - })); + } + return __Utils_Tuple0; }; const _Platform_effectManagerNameToString = name => name; diff --git a/src/Platform.elm b/src/Platform.elm index 2c7a737b..cd383ebc 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -274,16 +274,12 @@ setupEffectsChannel sendToApp2 = -- Reset and re-register all subscriptions. () = resetSubscriptions - (\addSubscription -> - subs - |> List.map createPlatformEffectFuncsFromSub - |> List.foldr - (\( id, tagger ) () -> - addSubscription - id - (\v -> sendToApp2 (tagger v) AsyncUpdate) - ) - () + (subs + |> List.map createPlatformEffectFuncsFromSub + |> List.map + (\( id, tagger ) -> + (id, (\v -> sendToApp2 (tagger v) AsyncUpdate)) + ) ) in cmdTask @@ -611,6 +607,6 @@ createPlatformEffectFuncsFromSub = Elm.Kernel.Basics.fudgeType -resetSubscriptions : ((IncomingPortId -> (HiddenConvertedSubType -> ()) -> ()) -> ()) -> () +resetSubscriptions : List (IncomingPortId, HiddenConvertedSubType -> ()) -> () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions From 4fb74aa2d206d63b91b7dd916c789f3a1975217f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 22:41:50 +0100 Subject: [PATCH 115/170] tidy resetSubscriptions api (again) to use tasks --- src/Elm/Kernel/Platform.js | 6 +++--- src/Platform.elm | 22 +++++++++++----------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 71ba80a9..351d26be 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -349,7 +349,7 @@ const _Platform_createSubProcess = createTask => { return key; }; -const _Platform_resetSubscriptions = newSubs => { +const _Platform_resetSubscriptions = newSubs => __Scheduler_binding(doneCallback => { for (const sendToApps of _Platform_subscriptionMap.values()) { sendToApps.length = 0; } @@ -364,8 +364,8 @@ const _Platform_resetSubscriptions = newSubs => { //*/ sendToApps.push(sendToApp); } - return __Utils_Tuple0; -}; + doneCallback(__Scheduler_succeed(__Utils_Tuple0)); +}); const _Platform_effectManagerNameToString = name => name; diff --git a/src/Platform.elm b/src/Platform.elm index cd383ebc..effcfa01 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -272,18 +272,18 @@ setupEffectsChannel sendToApp2 = |> runCmds -- Reset and re-register all subscriptions. - () = - resetSubscriptions - (subs - |> List.map createPlatformEffectFuncsFromSub - |> List.map - (\( id, tagger ) -> - (id, (\v -> sendToApp2 (tagger v) AsyncUpdate)) - ) - ) + subTask = + subs + |> List.map createPlatformEffectFuncsFromSub + |> List.map + (\( id, tagger ) -> + (id, (\v -> sendToApp2 (tagger v) AsyncUpdate)) + ) + |> resetSubscriptions + |> unwrapTask in cmdTask - |> RawTask.map (\_ -> ()) + |> RawTask.andThen (\_ -> subTask) dispatchTask : () -> RawTask.Task () dispatchTask () = @@ -607,6 +607,6 @@ createPlatformEffectFuncsFromSub = Elm.Kernel.Basics.fudgeType -resetSubscriptions : List (IncomingPortId, HiddenConvertedSubType -> ()) -> () +resetSubscriptions : List (IncomingPortId, HiddenConvertedSubType -> ()) -> Task Never () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions From ce538898d5f2627cb105ac2d2b4e7d80aa1bda3e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 22:47:28 +0100 Subject: [PATCH 116/170] replace sync scheduler binding with execImpure --- src/Elm/Kernel/Platform.js | 16 +++++++--------- src/Platform/Scheduler.elm | 14 ++++++++++++++ 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 351d26be..e6de821c 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -9,7 +9,7 @@ import Result exposing (isOk) import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId, initializeHelperFunctions) import Platform.Effects as Effects exposing (mapCommand) -import Platform.Scheduler as Scheduler exposing (binding, succeed, rawSpawn, andThen) +import Platform.Scheduler as Scheduler exposing (execImpure, rawSpawn, andThen) import Platform.Channel as NiceChannel exposing (recv, send) */ @@ -246,10 +246,9 @@ function _Platform_outgoingPort(name, converter) return payload => A2( _Platform_leaf, '000PlatformEffect', - __Scheduler_binding(doneCallback => { + __Scheduler_execImpure(_ => { execSubscribers(payload); - doneCallback(__Scheduler_succeed(__Maybe_Nothing)); - return x => x; + return __Maybe_Nothing; }) ); } @@ -324,7 +323,7 @@ const _Platform_createSubProcess = createTask => { const mappedSender = A2( __Channel_mapSender, val => { - return __Scheduler_binding(doneCallback => { + return __Scheduler_execImpure(_ => { const sendToApps = _Platform_subscriptionMap.get(key); /**__DEBUG/ if (sendToApps === undefined) { @@ -334,8 +333,7 @@ const _Platform_createSubProcess = createTask => { for (const sendToApp of sendToApps) { sendToApp(val); } - doneCallback(__Scheduler_succeed(__Utils_Tuple0)); - return x => x; + return __Utils_Tuple0; }); }, channel.a, @@ -349,7 +347,7 @@ const _Platform_createSubProcess = createTask => { return key; }; -const _Platform_resetSubscriptions = newSubs => __Scheduler_binding(doneCallback => { +const _Platform_resetSubscriptions = newSubs => __Scheduler_execImpure(_ => { for (const sendToApps of _Platform_subscriptionMap.values()) { sendToApps.length = 0; } @@ -364,7 +362,7 @@ const _Platform_resetSubscriptions = newSubs => __Scheduler_binding(doneCallback //*/ sendToApps.push(sendToApp); } - doneCallback(__Scheduler_succeed(__Utils_Tuple0)); + return __Utils_Tuple0; }); const _Platform_effectManagerNameToString = name => name; diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 98e8e3bc..bce08a91 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -81,6 +81,20 @@ binding callback = ) +{-| Create a task that executes a non pure function +-} +execImpure : (() -> a) -> Platform.Task Never a +execImpure func = + binding + (\doneCallback -> + let + () = + doneCallback (succeed (func ())) + in + \() -> () + ) + + andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 andThen func = wrapTaskFn From 0050091c9addb0b05b04914726821aff8dee3212 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 22:55:56 +0100 Subject: [PATCH 117/170] avoid use of impure channel api in elm --- src/Elm/Kernel/Platform.js | 2 +- src/Platform.elm | 20 ++++++++++++-------- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index e6de821c..e73ef6ee 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -65,7 +65,7 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { fx.__subs, ); for (const [key, selfSender] of selfSenders.entries()) { - A2(dispatcher, key, selfSender); + __Scheduler_rawSpawn(A2(dispatcher, key, selfSender)); } } } diff --git a/src/Platform.elm b/src/Platform.elm index effcfa01..b8cae113 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -77,12 +77,13 @@ type alias InitializeHelperFunctions model appMsg = -> Sub appMsg -> Bag.EffectManagerName -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) - -> () + -> Task Never () } {-| Kernel code relies on this definition existing and on the behaviour of these functions. -} +initializeHelperFunctions : InitializeHelperFunctions model msg initializeHelperFunctions = { stepperBuilder = \_ _ -> \_ _ -> () , setupIncomingPort = setupIncomingPort @@ -330,7 +331,7 @@ dispatchEffects : -> Sub appMsg -> Bag.EffectManagerName -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) - -> () + -> Task never () dispatchEffects cmdBag subBag = let effectsDict = @@ -344,13 +345,12 @@ dispatchEffects cmdBag subBag = Maybe.withDefault ( [], [] ) (Dict.get (effectManagerNameToString key) effectsDict) - - _ = - Channel.rawSend - channel - (App (createHiddenMyCmdList cmdList) (createHiddenMySubList subList)) in - () + wrapTask + (Channel.send + channel + (App (createHiddenMyCmdList cmdList) (createHiddenMySubList subList)) + ) gatherCmds : @@ -490,6 +490,10 @@ unwrapTask (Task task) = ) task +wrapTask : RawTask.Task a -> Task never a +wrapTask task = + Task (RawTask.map Ok task) + type alias SendToApp msg = msg -> UpdateMetadata -> () From 21af763e890959857872b623b51aef42808174ad Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 23:10:47 +0100 Subject: [PATCH 118/170] remove old incoming port manager --- src/Platform.elm | 38 +++----------------------------------- 1 file changed, 3 insertions(+), 35 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index b8cae113..e626e0fd 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -60,10 +60,6 @@ code in Elm/Kernel/Platform.js. -} type alias InitializeHelperFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg - , setupIncomingPort : - SendToApp appMsg - -> (List (HiddenMySub appMsg) -> ()) - -> ( Channel.Sender (ReceivedData appMsg Never), Encode.Value -> List (HiddenMySub appMsg) -> () ) , setupEffectsChannel : SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) , setupEffects : @@ -86,7 +82,6 @@ type alias InitializeHelperFunctions model appMsg = initializeHelperFunctions : InitializeHelperFunctions model msg initializeHelperFunctions = { stepperBuilder = \_ _ -> \_ _ -> () - , setupIncomingPort = setupIncomingPort , setupEffects = setupEffects , dispatchEffects = dispatchEffects , setupEffectsChannel = setupEffectsChannel @@ -278,7 +273,7 @@ setupEffectsChannel sendToApp2 = |> List.map createPlatformEffectFuncsFromSub |> List.map (\( id, tagger ) -> - (id, (\v -> sendToApp2 (tagger v) AsyncUpdate)) + ( id, \v -> sendToApp2 (tagger v) AsyncUpdate ) ) |> resetSubscriptions |> unwrapTask @@ -298,34 +293,6 @@ setupEffectsChannel sendToApp2 = Tuple.first dispatchChannel -setupIncomingPort : - SendToApp msg - -> (List (HiddenMySub msg) -> ()) - -> ( Channel.Sender (ReceivedData msg Never), Encode.Value -> List (HiddenMySub msg) -> () ) -setupIncomingPort sendToApp2 updateSubs = - let - init = - RawTask.Value () - - onSelfMsg _ selfMsg () = - never selfMsg - - onEffects _ _ subList () = - RawTask.execImpure (\() -> updateSubs subList) - - onSend value subs = - List.foldr - (\sub () -> - sendToApp2 (sub value) AsyncUpdate - ) - () - (createIncomingPortConverters subs) - in - ( instantiateEffectManager sendToApp2 init onEffects onSelfMsg - , onSend - ) - - dispatchEffects : Cmd appMsg -> Sub appMsg @@ -490,6 +457,7 @@ unwrapTask (Task task) = ) task + wrapTask : RawTask.Task a -> Task never a wrapTask task = Task (RawTask.map Ok task) @@ -611,6 +579,6 @@ createPlatformEffectFuncsFromSub = Elm.Kernel.Basics.fudgeType -resetSubscriptions : List (IncomingPortId, HiddenConvertedSubType -> ()) -> Task Never () +resetSubscriptions : List ( IncomingPortId, HiddenConvertedSubType -> () ) -> Task Never () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions From 6eaee186c44f292e9b217be764ccb88ff75e1c36 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 23:44:59 +0100 Subject: [PATCH 119/170] make the ReceivedData custom type an impl. detail The ReceivedData custom type is a nice description of how the process of an effect manager can receive 'app messages' and 'self messages'. However, given we are trying to move away from effect managers it makes sense to sideline this type. --- src/Elm/Kernel/Platform.js | 18 +++-- src/Platform.elm | 130 ++++++++++++++++++++----------------- 2 files changed, 82 insertions(+), 66 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index e73ef6ee..4d9fe216 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -79,14 +79,18 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { selfSenders.set('000PlatformEffect', __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp)); for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { - const manager = A4( - __Platform_initializeHelperFunctions.__$setupEffects, - sendToApp, - effectManagerFunctions.__init, - effectManagerFunctions.__fullOnEffects, - effectManagerFunctions.__onSelfMsg + const managerChannel = __Channel_rawUnbounded(__Utils_Tuple0); + __Scheduler_rawSpawn( + A5( + __Platform_initializeHelperFunctions.__$setupEffects, + sendToApp, + managerChannel.b, + effectManagerFunctions.__init, + effectManagerFunctions.__fullOnEffects, + effectManagerFunctions.__onSelfMsg + ) ); - selfSenders.set(key, manager); + selfSenders.set(key, managerChannel.a); } for (const [key, {port}] of _Platform_outgoingPorts.entries()) { ports[key] = port; diff --git a/src/Platform.elm b/src/Platform.elm index e626e0fd..e4ce5582 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -61,18 +61,19 @@ code in Elm/Kernel/Platform.js. type alias InitializeHelperFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg , setupEffectsChannel : - SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) + SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) , setupEffects : SendToApp appMsg + -> Channel.Receiver (AppMsgPayload appMsg) -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) + -> Task Never Never , dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Sender (AppMsgPayload appMsg) -> Task Never () } @@ -176,7 +177,7 @@ the main app and your individual effect manager. type Router appMsg selfMsg = Router { sendToApp : appMsg -> () - , selfSender : Channel.Sender (ReceivedData appMsg selfMsg) + , selfSender : selfMsg -> RawTask.Task () } @@ -197,7 +198,7 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () sendToSelf (Router router) msg = - Task (RawTask.map Ok (Channel.send router.selfSender (Self msg))) + wrapTask (router.selfSender msg) @@ -216,10 +217,10 @@ Never ()`. We must call it with a channel that forwards all messages to the app's main update cycle (i.e. the receiver will call sendToApp2). -} -setupEffectsChannel : SendToApp appMsg -> Channel.Sender (ReceivedData appMsg Never) +setupEffectsChannel : SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) setupEffectsChannel sendToApp2 = let - dispatchChannel : Channel.Channel (ReceivedData appMsg Never) + dispatchChannel : Channel.Channel (AppMsgPayload appMsg) dispatchChannel = Channel.rawUnbounded () @@ -254,32 +255,27 @@ setupEffectsChannel sendToApp2 = (RawTask.Value []) >> RawTask.andThen RawScheduler.batch - receiveMsg : ReceivedData appMsg Never -> RawTask.Task () - receiveMsg msg = - case msg of - Self value -> - never value - - App cmds subs -> - let - cmdTask = - cmds - |> List.map createPlatformEffectFuncsFromCmd - |> runCmds - - -- Reset and re-register all subscriptions. - subTask = - subs - |> List.map createPlatformEffectFuncsFromSub - |> List.map - (\( id, tagger ) -> - ( id, \v -> sendToApp2 (tagger v) AsyncUpdate ) - ) - |> resetSubscriptions - |> unwrapTask - in - cmdTask - |> RawTask.andThen (\_ -> subTask) + receiveMsg : AppMsgPayload appMsg -> RawTask.Task () + receiveMsg ( cmds, subs ) = + let + cmdTask = + cmds + |> List.map createPlatformEffectFuncsFromCmd + |> runCmds + + -- Reset and re-register all subscriptions. + subTask = + subs + |> List.map createPlatformEffectFuncsFromSub + |> List.map + (\( id, tagger ) -> + ( id, \v -> sendToApp2 (tagger v) AsyncUpdate ) + ) + |> resetSubscriptions + |> unwrapTask + in + cmdTask + |> RawTask.andThen (\_ -> subTask) dispatchTask : () -> RawTask.Task () dispatchTask () = @@ -297,7 +293,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Bag.EffectManagerName - -> Channel.Sender (ReceivedData appMsg HiddenSelfMsg) + -> Channel.Sender (AppMsgPayload appMsg) -> Task never () dispatchEffects cmdBag subBag = let @@ -316,7 +312,7 @@ dispatchEffects cmdBag subBag = wrapTask (Channel.send channel - (App (createHiddenMyCmdList cmdList) (createHiddenMySubList subList)) + ( createHiddenMyCmdList cmdList, createHiddenMySubList subList ) ) @@ -379,32 +375,36 @@ createEffect isCmd newEffect maybeEffects = setupEffects : SendToApp appMsg + -> Channel.Receiver (AppMsgPayload appMsg) -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> Channel.Sender (ReceivedData appMsg selfMsg) -setupEffects sendToAppFunc init onEffects onSelfMsg = - instantiateEffectManager - sendToAppFunc - (unwrapTask init) - (\router cmds subs state -> unwrapTask (onEffects router cmds subs state)) - (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) + -> Task never Never +setupEffects sendToAppFunc receiver init onEffects onSelfMsg = + wrapTask + (instantiateEffectManager + sendToAppFunc + receiver + (unwrapTask init) + (\router cmds subs state -> unwrapTask (onEffects router cmds subs state)) + (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) + ) instantiateEffectManager : SendToApp appMsg + -> Channel.Receiver (AppMsgPayload appMsg) -> RawTask.Task state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawTask.Task state) -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) - -> Channel.Sender (ReceivedData appMsg selfMsg) -instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = + -> RawTask.Task Never +instantiateEffectManager sendToAppFunc appReceiver init onEffects onSelfMsg = let receiveMsg : - Channel.Receiver (ReceivedData appMsg selfMsg) - -> state + state -> ReceivedData appMsg selfMsg - -> RawTask.Task state - receiveMsg channel state msg = + -> RawTask.Task never + receiveMsg state msg = let task : RawTask.Task state task = @@ -412,7 +412,7 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = Self value -> onSelfMsg (Router router) value state - App cmds subs -> + App ( cmds, subs ) -> onEffects (Router router) cmds subs state in task @@ -422,26 +422,34 @@ instantiateEffectManager sendToAppFunc init onEffects onSelfMsg = (\() -> val) (RawTask.sleep 0) ) - |> RawTask.andThen (\newState -> Channel.recv (receiveMsg channel newState) channel) + |> RawTask.andThen (\newState -> Channel.recv (receiveMsg newState) selfReceiver) - initTask : RawTask.Task state + initTask : RawTask.Task never initTask = RawTask.sleep 0 |> RawTask.andThen (\_ -> init) - |> RawTask.andThen (\state -> Channel.recv (receiveMsg selfReceiver state) selfReceiver) + |> RawTask.andThen (\state -> Channel.recv (receiveMsg state) selfReceiver) - ( selfSender, selfReceiver ) = + selfChannel : Channel.Channel (ReceivedData appMsg selfMsg) + selfChannel = Channel.rawUnbounded () + ( selfSender, selfReceiver ) = + selfChannel + + forwardAppMessagesTask () = + Channel.recv + (\payload -> Channel.send selfSender (App payload)) + appReceiver + |> RawTask.andThen forwardAppMessagesTask + router = { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfSender = selfSender + , selfSender = \msg -> Channel.send selfSender (Self msg) } - - selfProcessId = - RawScheduler.rawSpawn initTask in - selfSender + RawScheduler.spawn (forwardAppMessagesTask ()) + |> RawTask.andThen (\_ -> initTask) unwrapTask : Task Never a -> RawTask.Task a @@ -491,7 +499,11 @@ type HiddenConvertedSubType type ReceivedData appMsg selfMsg = Self selfMsg - | App (List (HiddenMyCmd appMsg)) (List (HiddenMySub appMsg)) + | App (AppMsgPayload appMsg) + + +type alias AppMsgPayload appMsg = + ( List (HiddenMyCmd appMsg), List (HiddenMySub appMsg) ) type HiddenMyCmd msg From 1e33f7206879d90e55fec4ac27feb5d6994abcf8 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 12 Apr 2020 23:54:30 +0100 Subject: [PATCH 120/170] avoid impure channel creation --- src/Platform.elm | 20 +++++++++++++------- src/Platform/Channel.elm | 6 +++--- src/Platform/Raw/Channel.elm | 4 ++-- 3 files changed, 18 insertions(+), 12 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index e4ce5582..837aa6a3 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -399,6 +399,19 @@ instantiateEffectManager : -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) -> RawTask.Task Never instantiateEffectManager sendToAppFunc appReceiver init onEffects onSelfMsg = + Channel.unbounded + |> RawTask.andThen (instantiateEffectManagerWithSelfChannel sendToAppFunc appReceiver init onEffects onSelfMsg) + + +instantiateEffectManagerWithSelfChannel : + SendToApp appMsg + -> Channel.Receiver (AppMsgPayload appMsg) + -> RawTask.Task state + -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawTask.Task state) + -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) + -> Channel.Channel (ReceivedData appMsg selfMsg) + -> RawTask.Task Never +instantiateEffectManagerWithSelfChannel sendToAppFunc appReceiver init onEffects onSelfMsg ( selfSender, selfReceiver ) = let receiveMsg : state @@ -430,13 +443,6 @@ instantiateEffectManager sendToAppFunc appReceiver init onEffects onSelfMsg = |> RawTask.andThen (\_ -> init) |> RawTask.andThen (\state -> Channel.recv (receiveMsg state) selfReceiver) - selfChannel : Channel.Channel (ReceivedData appMsg selfMsg) - selfChannel = - Channel.rawUnbounded () - - ( selfSender, selfReceiver ) = - selfChannel - forwardAppMessagesTask () = Channel.recv (\payload -> Channel.send selfSender (App payload)) diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm index a173d6c7..ab4be82a 100644 --- a/src/Platform/Channel.elm +++ b/src/Platform/Channel.elm @@ -31,9 +31,9 @@ send channelId msg = Scheduler.wrapTask (RawTask.map Ok (RawChannel.send channelId msg)) -unbounded : () -> Platform.Task never ( Sender msg, Receiver msg ) -unbounded () = - Scheduler.wrapTask (RawTask.map Ok (RawChannel.unbounded ())) +unbounded : Platform.Task never ( Sender msg, Receiver msg ) +unbounded = + Scheduler.wrapTask (RawTask.map Ok RawChannel.unbounded) mapSender : (b -> a) -> Sender a -> Sender b diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index 81c5ce7f..997baa4d 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -61,8 +61,8 @@ rawUnbounded = Elm.Kernel.Channel.rawUnbounded -unbounded : () -> RawTask.Task ( Sender msg, Receiver msg ) -unbounded () = +unbounded : RawTask.Task ( Sender msg, Receiver msg ) +unbounded = RawTask.execImpure rawUnbounded From 340ae75ac1e793b221a9412af879d11ba694b691 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Mon, 13 Apr 2020 00:41:12 +0100 Subject: [PATCH 121/170] remove mapSender This is something I have been trying todo since almost before I introduced the function. Before this commit there was only one place that used the function and by refactoring that I can remove the function entirely. The `_Platform_subscriptionInit` introduced in this commit works around an issue where kernel code that runs "before main" cannot access functions defined in elm. --- src/Elm/Kernel/Channel.js | 5 --- src/Elm/Kernel/Platform.js | 81 ++++++++++++++---------------------- src/Platform/Channel.elm | 7 +--- src/Platform/Raw/Channel.elm | 7 +--- 4 files changed, 34 insertions(+), 66 deletions(-) diff --git a/src/Elm/Kernel/Channel.js b/src/Elm/Kernel/Channel.js index b8e2c6ab..98cfc3a7 100644 --- a/src/Elm/Kernel/Channel.js +++ b/src/Elm/Kernel/Channel.js @@ -82,8 +82,3 @@ const _Channel_rawSendImpl = F2((channelId, msg) => { const _Channel_rawSend = F2((sender, msg) => { sender(msg); }); - - -const _Channel_mapSender = F2((func, sender) => { - return val => sender(func(val)); -}); diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 4d9fe216..fa60913c 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -4,7 +4,7 @@ import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) import Elm.Kernel.List exposing (Cons, Nil, toArray) import Elm.Kernel.Utils exposing (Tuple0, Tuple2) -import Elm.Kernel.Channel exposing (rawUnbounded, rawSend, mapSender) +import Elm.Kernel.Channel exposing (rawUnbounded, rawSend) import Result exposing (isOk) import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId, initializeHelperFunctions) @@ -77,6 +77,10 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { dispatch(model, updateValue.b); }); + for (const init of _Platform_subscriptionInit) { + __Scheduler_rawSpawn(init(__Utils_Tuple0)); + } + selfSenders.set('000PlatformEffect', __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp)); for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { const managerChannel = __Channel_rawUnbounded(__Utils_Tuple0); @@ -261,7 +265,10 @@ function _Platform_outgoingPort(name, converter) function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - const channel = __Channel_rawUnbounded(); + + const tuple = _Platform_createSubProcess(); + const key = tuple.a; + const sender = tuple.b; function send(incomingValue) { @@ -270,7 +277,7 @@ function _Platform_incomingPort(name, converter) __Result_isOk(result) || __Debug_crash(4, name, result.a); var value = result.a; - A2(__Channel_rawSend, channel.a, value); + A2(__Channel_rawSend, sender, value); } _Platform_incomingPorts.set( @@ -282,20 +289,6 @@ function _Platform_incomingPort(name, converter) } ); - const key = _Platform_createSubProcess(sender => { - const onMsgReceive = receiver => - A2( - __Scheduler_andThen, - _ => onMsgReceive(receiver), - A2( - __NiceChannel_recv, - __NiceChannel_send(sender), - receiver - ) - ); - return onMsgReceive(channel.b); - }); - return tagger => A2( _Platform_leaf, '000PlatformEffect', @@ -307,48 +300,38 @@ function _Platform_incomingPort(name, converter) // Functions exported to elm const _Platform_subscriptionMap = new Map(); +const _Platform_subscriptionInit = []; let _Platform_subscriptionProcessIds = 0; -const _Platform_createSubProcess = createTask => { +const _Platform_createSubProcess = _ => { const channel = __Channel_rawUnbounded(); const key = { id: _Platform_subscriptionProcessIds++ }; - const onSubEffects = receiver => + const msgHandler = msg => { + return __Scheduler_execImpure(_ => { + const sendToApps = _Platform_subscriptionMap.get(key); + /**__DEBUG/ + if (sendToApps === undefined) { + __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); + } + //*/ + for (const sendToApp of sendToApps) { + sendToApp(msg); + } + return __Utils_Tuple0; + }); + }; + + const onSubEffects = _ => A2( __Scheduler_andThen, - _ => onSubEffects(receiver), - A2( - __NiceChannel_recv, - t => t, - receiver, - ) + onSubEffects, + A2(__NiceChannel_recv, msgHandler, channel.b), ); _Platform_subscriptionMap.set(key, []); - const mappedSender = A2( - __Channel_mapSender, - val => { - return __Scheduler_execImpure(_ => { - const sendToApps = _Platform_subscriptionMap.get(key); - /**__DEBUG/ - if (sendToApps === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); - } - //*/ - for (const sendToApp of sendToApps) { - sendToApp(val); - } - return __Utils_Tuple0; - }); - }, - channel.a, - ); - - Promise.resolve().then(() => { - __Scheduler_rawSpawn(createTask(mappedSender)); - __Scheduler_rawSpawn(onSubEffects(channel.b)); - }); + _Platform_subscriptionInit.push(onSubEffects); - return key; + return __Utils_Tuple2(key, channel.a); }; const _Platform_resetSubscriptions = newSubs => __Scheduler_execImpure(_ => { diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm index ab4be82a..7ac56d77 100644 --- a/src/Platform/Channel.elm +++ b/src/Platform/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Channel exposing (Receiver, Sender, mapSender, recv, send, unbounded) +module Platform.Channel exposing (Receiver, Sender, recv, send, unbounded) import Basics exposing (..) import Debug @@ -34,8 +34,3 @@ send channelId msg = unbounded : Platform.Task never ( Sender msg, Receiver msg ) unbounded = Scheduler.wrapTask (RawTask.map Ok RawChannel.unbounded) - - -mapSender : (b -> a) -> Sender a -> Sender b -mapSender = - RawChannel.mapSender diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index 997baa4d..d86b185b 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Channel exposing (Channel, Receiver, Sender, mapSender, rawSend, rawUnbounded, recv, send, tryRecv, unbounded) +module Platform.Raw.Channel exposing (Channel, Receiver, Sender, rawSend, rawUnbounded, recv, send, tryRecv, unbounded) import Basics exposing (..) import Debug @@ -74,8 +74,3 @@ rawRecv = rawTryRecv : Receiver msg -> Maybe msg rawTryRecv = Elm.Kernel.Channel.rawTryRecv - - -mapSender : (b -> a) -> Sender a -> Sender b -mapSender = - Elm.Kernel.Channel.mapSender From dd61908e4f0952a63df95e16257e3f12958cc913 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 19:23:01 +0100 Subject: [PATCH 122/170] remove non-raw channel api less code = better code --- src/Elm/Kernel/Platform.js | 12 +++++++----- src/Platform/Channel.elm | 36 ------------------------------------ 2 files changed, 7 insertions(+), 41 deletions(-) delete mode 100644 src/Platform/Channel.elm diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index fa60913c..58ff317b 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -10,7 +10,9 @@ import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId, initializeHelperFunctions) import Platform.Effects as Effects exposing (mapCommand) import Platform.Scheduler as Scheduler exposing (execImpure, rawSpawn, andThen) -import Platform.Channel as NiceChannel exposing (recv, send) +import Platform.Raw.Scheduler as RawScheduler exposing (rawSpawn) +import Platform.Raw.Task as RawTask exposing (execImpure, andThen) +import Platform.Raw.Channel as RawChannel exposing (recv) */ @@ -78,7 +80,7 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { }); for (const init of _Platform_subscriptionInit) { - __Scheduler_rawSpawn(init(__Utils_Tuple0)); + __RawScheduler_rawSpawn(init(__Utils_Tuple0)); } selfSenders.set('000PlatformEffect', __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp)); @@ -307,7 +309,7 @@ const _Platform_createSubProcess = _ => { const channel = __Channel_rawUnbounded(); const key = { id: _Platform_subscriptionProcessIds++ }; const msgHandler = msg => { - return __Scheduler_execImpure(_ => { + return __RawTask_execImpure(_ => { const sendToApps = _Platform_subscriptionMap.get(key); /**__DEBUG/ if (sendToApps === undefined) { @@ -323,9 +325,9 @@ const _Platform_createSubProcess = _ => { const onSubEffects = _ => A2( - __Scheduler_andThen, + __RawTask_andThen, onSubEffects, - A2(__NiceChannel_recv, msgHandler, channel.b), + A2(__RawChannel_recv, msgHandler, channel.b), ); _Platform_subscriptionMap.set(key, []); diff --git a/src/Platform/Channel.elm b/src/Platform/Channel.elm deleted file mode 100644 index 7ac56d77..00000000 --- a/src/Platform/Channel.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Platform.Channel exposing (Receiver, Sender, recv, send, unbounded) - -import Basics exposing (..) -import Debug -import Maybe exposing (Maybe(..)) -import Platform -import Platform.Raw.Channel as RawChannel -import Platform.Raw.Task as RawTask -import Platform.Scheduler as Scheduler -import Result exposing (Result(..)) - - -type alias Sender msg = - RawChannel.Sender msg - - -type alias Receiver msg = - RawChannel.Receiver msg - - -{-| -} -recv : (msg -> Platform.Task Never a) -> Receiver msg -> Platform.Task Never a -recv tagger chl = - Scheduler.wrapTask (RawChannel.recv (\msg -> Scheduler.unwrapTask (tagger msg)) chl) - - -{-| Create a task, if run, will send a message to a channel. --} -send : Sender msg -> msg -> Platform.Task never () -send channelId msg = - Scheduler.wrapTask (RawTask.map Ok (RawChannel.send channelId msg)) - - -unbounded : Platform.Task never ( Sender msg, Receiver msg ) -unbounded = - Scheduler.wrapTask (RawTask.map Ok RawChannel.unbounded) From dca308b080e7b4e59175afc1a3c1cf5b87bce2ff Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 19:29:39 +0100 Subject: [PATCH 123/170] use raw task in resetSubscriptions --- src/Elm/Kernel/Platform.js | 2 +- src/Platform.elm | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 58ff317b..c1eb9920 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -336,7 +336,7 @@ const _Platform_createSubProcess = _ => { return __Utils_Tuple2(key, channel.a); }; -const _Platform_resetSubscriptions = newSubs => __Scheduler_execImpure(_ => { +const _Platform_resetSubscriptions = newSubs => __RawTask_execImpure(_ => { for (const sendToApps of _Platform_subscriptionMap.values()) { sendToApps.length = 0; } diff --git a/src/Platform.elm b/src/Platform.elm index 837aa6a3..ea7f18f2 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -272,7 +272,6 @@ setupEffectsChannel sendToApp2 = ( id, \v -> sendToApp2 (tagger v) AsyncUpdate ) ) |> resetSubscriptions - |> unwrapTask in cmdTask |> RawTask.andThen (\_ -> subTask) @@ -597,6 +596,6 @@ createPlatformEffectFuncsFromSub = Elm.Kernel.Basics.fudgeType -resetSubscriptions : List ( IncomingPortId, HiddenConvertedSubType -> () ) -> Task Never () +resetSubscriptions : List ( IncomingPortId, HiddenConvertedSubType -> () ) -> RawTask.Task () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions From 1994625b09ee81d3dde94382e191f6c64533f702 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 19:46:46 +0100 Subject: [PATCH 124/170] have dispatch effects return a raw task --- src/Elm/Kernel/Platform.js | 2 +- src/Platform.elm | 13 ++++++------- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index c1eb9920..d940af4e 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -67,7 +67,7 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { fx.__subs, ); for (const [key, selfSender] of selfSenders.entries()) { - __Scheduler_rawSpawn(A2(dispatcher, key, selfSender)); + __RawScheduler_rawSpawn(A2(dispatcher, key, selfSender)); } } } diff --git a/src/Platform.elm b/src/Platform.elm index ea7f18f2..ec48f63a 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -74,7 +74,7 @@ type alias InitializeHelperFunctions model appMsg = -> Sub appMsg -> Bag.EffectManagerName -> Channel.Sender (AppMsgPayload appMsg) - -> Task Never () + -> RawTask.Task () } @@ -293,7 +293,7 @@ dispatchEffects : -> Sub appMsg -> Bag.EffectManagerName -> Channel.Sender (AppMsgPayload appMsg) - -> Task never () + -> RawTask.Task () dispatchEffects cmdBag subBag = let effectsDict = @@ -308,11 +308,10 @@ dispatchEffects cmdBag subBag = ( [], [] ) (Dict.get (effectManagerNameToString key) effectsDict) in - wrapTask - (Channel.send - channel - ( createHiddenMyCmdList cmdList, createHiddenMySubList subList ) - ) + Channel.send + channel + ( createHiddenMyCmdList cmdList, createHiddenMySubList subList ) + gatherCmds : From d0df42f7d9176909fcd0ba9daceb7aa3ffb903c7 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 19:52:00 +0100 Subject: [PATCH 125/170] have setupEffects return a raw task --- src/Elm/Kernel/Platform.js | 4 ++-- src/Platform.elm | 19 +++++++++---------- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index d940af4e..658280b7 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -9,7 +9,7 @@ import Result exposing (isOk) import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId, initializeHelperFunctions) import Platform.Effects as Effects exposing (mapCommand) -import Platform.Scheduler as Scheduler exposing (execImpure, rawSpawn, andThen) +import Platform.Scheduler as Scheduler exposing (execImpure) import Platform.Raw.Scheduler as RawScheduler exposing (rawSpawn) import Platform.Raw.Task as RawTask exposing (execImpure, andThen) import Platform.Raw.Channel as RawChannel exposing (recv) @@ -86,7 +86,7 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { selfSenders.set('000PlatformEffect', __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp)); for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { const managerChannel = __Channel_rawUnbounded(__Utils_Tuple0); - __Scheduler_rawSpawn( + __RawScheduler_rawSpawn( A5( __Platform_initializeHelperFunctions.__$setupEffects, sendToApp, diff --git a/src/Platform.elm b/src/Platform.elm index ec48f63a..3999cc71 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -68,7 +68,7 @@ type alias InitializeHelperFunctions model appMsg = -> Task Never HiddenState -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> Task Never Never + -> RawTask.Task Never , dispatchEffects : Cmd appMsg -> Sub appMsg @@ -377,16 +377,15 @@ setupEffects : -> Task Never state -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> Task never Never + -> RawTask.Task Never setupEffects sendToAppFunc receiver init onEffects onSelfMsg = - wrapTask - (instantiateEffectManager - sendToAppFunc - receiver - (unwrapTask init) - (\router cmds subs state -> unwrapTask (onEffects router cmds subs state)) - (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) - ) + instantiateEffectManager + sendToAppFunc + receiver + (unwrapTask init) + (\router cmds subs state -> unwrapTask (onEffects router cmds subs state)) + (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) + instantiateEffectManager : From 9afb1047ce4df7c2a8af3c1356dc58b16b027e7c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 20:00:37 +0100 Subject: [PATCH 126/170] tidy setupEffectsChannel --- src/Platform.elm | 60 ++++++++++++++++++++++-------------------------- 1 file changed, 28 insertions(+), 32 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 3999cc71..c1e6c1d2 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -224,44 +224,40 @@ setupEffectsChannel sendToApp2 = dispatchChannel = Channel.rawUnbounded () - runCmds : List (Task Never (Maybe appMsg)) -> RawTask.Task RawScheduler.ProcessId - runCmds = - List.map (\(Task t) -> t) - >> List.map - (RawTask.map - (\r -> - case r of - Ok (Just msg) -> - sendToApp2 msg AsyncUpdate - - Ok Nothing -> - () - - Err err -> - never err - ) - ) - >> List.map RawScheduler.spawn - >> List.foldr - (\curr accTask -> - RawTask.andThen - (\acc -> - RawTask.map - (\id -> id :: acc) - curr - ) - accTask - ) - (RawTask.Value []) - >> RawTask.andThen RawScheduler.batch - receiveMsg : AppMsgPayload appMsg -> RawTask.Task () receiveMsg ( cmds, subs ) = let cmdTask = cmds |> List.map createPlatformEffectFuncsFromCmd - |> runCmds + |> List.map (\(Task t) -> t) + |> List.map + (RawTask.map + (\r -> + case r of + Ok (Just msg) -> + sendToApp2 msg AsyncUpdate + + Ok Nothing -> + () + + Err err -> + never err + ) + ) + |> List.map RawScheduler.spawn + |> List.foldr + (\curr accTask -> + RawTask.andThen + (\acc -> + RawTask.map + (\id -> id :: acc) + curr + ) + accTask + ) + (RawTask.Value []) + |> RawTask.andThen RawScheduler.batch -- Reset and re-register all subscriptions. subTask = From d1140763c5a7632e7917ad8bfff402a27e387d78 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 20:06:38 +0100 Subject: [PATCH 127/170] format --- src/Platform.elm | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index c1e6c1d2..751c3b54 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -309,7 +309,6 @@ dispatchEffects cmdBag subBag = ( createHiddenMyCmdList cmdList, createHiddenMySubList subList ) - gatherCmds : Cmd msg -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) @@ -383,7 +382,6 @@ setupEffects sendToAppFunc receiver init onEffects onSelfMsg = (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) - instantiateEffectManager : SendToApp appMsg -> Channel.Receiver (AppMsgPayload appMsg) From fb3ef8bd4a50c94520e4f3e555241f3bfcdb9fce Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 20:19:33 +0100 Subject: [PATCH 128/170] update setupEffectsChannel docs --- src/Platform.elm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 751c3b54..14108a35 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -212,9 +212,11 @@ The channel who's sender we return is a runtime specific channel, the thunk returned by dispatchEffects will use the sender to notify this function that we have command and/or subscriptions to process. -Each command or subscription is a function `Channel.Sender msg -> Platform.Task -Never ()`. We must call it with a channel that forwards all messages to the -app's main update cycle (i.e. the receiver will call sendToApp2). +Each command is a `Platform.Task Never (Maybe msg)`. If the Task resolves with +`Just something` we must send that `something` to the app. + +Each sub is a tuple `( IncomingPortId, HiddenConvertedSubType -> msg )` we can +collect these id's and functions and pass them to `resetSubscriptions`. -} setupEffectsChannel : SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) From cb019748b33f8e777b21fda5bf5181b3ec28d84b Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 20:21:41 +0100 Subject: [PATCH 129/170] update docs --- src/Platform.elm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Platform.elm b/src/Platform.elm index 14108a35..2e650f55 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -78,7 +78,7 @@ type alias InitializeHelperFunctions model appMsg = } -{-| Kernel code relies on this definition existing and on the behaviour of these functions. +{-| Kernel code relies on this definitions type and on the behaviour of these functions. -} initializeHelperFunctions : InitializeHelperFunctions model msg initializeHelperFunctions = From 3a1f989158f8a4cafba10004900cf14723e03b3a Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 20:52:31 +0100 Subject: [PATCH 130/170] prettier --- src/Elm/Kernel/Basics.js | 31 +- src/Elm/Kernel/Channel.js | 88 +++-- src/Elm/Kernel/Char.js | 57 ++-- src/Elm/Kernel/Debug.js | 620 ++++++++++++++++++------------------ src/Elm/Kernel/JsArray.js | 181 +++++------ src/Elm/Kernel/List.js | 36 +-- src/Elm/Kernel/Platform.js | 551 +++++++++++++++----------------- src/Elm/Kernel/Scheduler.js | 179 ++++++----- src/Elm/Kernel/String.js | 426 +++++++++++-------------- src/Elm/Kernel/Utils.js | 264 +++++++-------- 10 files changed, 1136 insertions(+), 1297 deletions(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index e67f92ad..28683356 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -16,7 +16,6 @@ const _Basics_asin = Math.asin; const _Basics_atan = Math.atan; const _Basics_atan2 = F2(Math.atan2); - const _Basics_ceiling = Math.ceil; const _Basics_floor = Math.floor; const _Basics_round = Math.round; @@ -25,18 +24,18 @@ const _Basics_log = Math.log; const _Basics_modBy0 = () => __Debug_crash(11); -const _Basics_fudgeType = x => x; - -const _Basics_unwrapTypeWrapper__DEBUG = wrapped => { - const entries = Object.entries(wrapped); - if (entries.length !== 2) { - __Debug_crash(12, __Debug_runtimeCrashReason('failedUnwrap'), wrapped); - } - if (entries[0][0] === '$') { - return entries[1][1]; - } else { - return entries[0][1]; - } -} - -const _Basics_unwrapTypeWrapper__PROD = wrapped => wrapped; +const _Basics_fudgeType = (x) => x; + +const _Basics_unwrapTypeWrapper__DEBUG = (wrapped) => { + const entries = Object.entries(wrapped); + if (entries.length !== 2) { + __Debug_crash(12, __Debug_runtimeCrashReason("failedUnwrap"), wrapped); + } + if (entries[0][0] === "$") { + return entries[1][1]; + } else { + return entries[0][1]; + } +}; + +const _Basics_unwrapTypeWrapper__PROD = (wrapped) => wrapped; diff --git a/src/Elm/Kernel/Channel.js b/src/Elm/Kernel/Channel.js index 98cfc3a7..67c1cdf6 100644 --- a/src/Elm/Kernel/Channel.js +++ b/src/Elm/Kernel/Channel.js @@ -8,77 +8,73 @@ import Elm.Kernel.Utils exposing (Tuple2) const _Channel_channels = new WeakMap(); let _Channel_channelId = 0; -const _Channel_rawUnbounded = _ => { - const id = { - id: _Channel_channelId++ - }; - _Channel_channels.set(id, { - messages: [], - wakers: new Set(), - }); - return __Utils_Tuple2(_Channel_rawSendImpl(id), id); -} - +const _Channel_rawUnbounded = (_) => { + const id = { + id: _Channel_channelId++, + }; + _Channel_channels.set(id, { + messages: [], + wakers: new Set(), + }); + return __Utils_Tuple2(_Channel_rawSendImpl(id), id); +}; const _Channel_rawTryRecv = (channelId) => { - const channel = _Channel_channels.get(channelId); - /**__DEBUG/ + const channel = _Channel_channels.get(channelId); + /**__DEBUG/ if (channel === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); } //*/ - const msg = channel.messages.shift(); - if (msg === undefined) { - return __Maybe_Nothing; - } else { - return __Maybe_Just(msg); - } + const msg = channel.messages.shift(); + if (msg === undefined) { + return __Maybe_Nothing; + } else { + return __Maybe_Just(msg); + } }; - const _Channel_rawRecv = F2((channelId, onMsg) => { const channel = _Channel_channels.get(channelId); - /**__DEBUG/ + /**__DEBUG/ if (channel === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); } //*/ - const msg = channel.messages.shift(); - if (msg !== undefined) { + const msg = channel.messages.shift(); + if (msg !== undefined) { onMsg(msg); - return x => x; - } - const onWake = msg => { - return onMsg(msg); - } - channel.wakers.add(onWake); - return x => { - channel.wakers.delete(onWake); - return x; - }; + return (x) => x; + } + const onWake = (msg) => { + return onMsg(msg); + }; + channel.wakers.add(onWake); + return (x) => { + channel.wakers.delete(onWake); + return x; + }; }); - const _Channel_rawSendImpl = F2((channelId, msg) => { - const channel = _Channel_channels.get(channelId); - /**__DEBUG/ + const channel = _Channel_channels.get(channelId); + /**__DEBUG/ if (channel === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); } //*/ - const wakerIter = channel.wakers[Symbol.iterator](); - const { value: nextWaker, done } = wakerIter.next(); - if (done) { - channel.messages.push(msg); - } else { - channel.wakers.delete(nextWaker); - nextWaker(msg); - } - return _Utils_Tuple0; + const wakerIter = channel.wakers[Symbol.iterator](); + const { value: nextWaker, done } = wakerIter.next(); + if (done) { + channel.messages.push(msg); + } else { + channel.wakers.delete(nextWaker); + nextWaker(msg); + } + return _Utils_Tuple0; }); - const _Channel_rawSend = F2((sender, msg) => { sender(msg); }); diff --git a/src/Elm/Kernel/Char.js b/src/Elm/Kernel/Char.js index 7cc9aa74..dd1e6a11 100644 --- a/src/Elm/Kernel/Char.js +++ b/src/Elm/Kernel/Char.js @@ -4,48 +4,37 @@ import Elm.Kernel.Utils exposing (chr) */ - -function _Char_toCode(char) -{ - var code = char.charCodeAt(0); - if (0xD800 <= code && code <= 0xDBFF) - { - return (code - 0xD800) * 0x400 + char.charCodeAt(1) - 0xDC00 + 0x10000 - } - return code; +function _Char_toCode(char) { + var code = char.charCodeAt(0); + if (0xd800 <= code && code <= 0xdbff) { + return (code - 0xd800) * 0x400 + char.charCodeAt(1) - 0xdc00 + 0x10000; + } + return code; } -function _Char_fromCode(code) -{ - return __Utils_chr( - (code < 0 || 0x10FFFF < code) - ? '\uFFFD' - : - (code <= 0xFFFF) - ? String.fromCharCode(code) - : - (code -= 0x10000, - String.fromCharCode(Math.floor(code / 0x400) + 0xD800, code % 0x400 + 0xDC00) - ) - ); +function _Char_fromCode(code) { + return __Utils_chr( + code < 0 || 0x10ffff < code + ? "\uFFFD" + : code <= 0xffff + ? String.fromCharCode(code) + : ((code -= 0x10000), + String.fromCharCode(Math.floor(code / 0x400) + 0xd800, (code % 0x400) + 0xdc00)) + ); } -function _Char_toUpper(char) -{ - return __Utils_chr(char.toUpperCase()); +function _Char_toUpper(char) { + return __Utils_chr(char.toUpperCase()); } -function _Char_toLower(char) -{ - return __Utils_chr(char.toLowerCase()); +function _Char_toLower(char) { + return __Utils_chr(char.toLowerCase()); } -function _Char_toLocaleUpper(char) -{ - return __Utils_chr(char.toLocaleUpperCase()); +function _Char_toLocaleUpper(char) { + return __Utils_chr(char.toLocaleUpperCase()); } -function _Char_toLocaleLower(char) -{ - return __Utils_chr(char.toLocaleLowerCase()); +function _Char_toLocaleLower(char) { + return __Utils_chr(char.toLocaleLowerCase()); } diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 16023b18..1b2311b5 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -6,364 +6,358 @@ import Set exposing (toList) */ - // LOG -var _Debug_log__PROD = F2(function(tag, value) -{ - return value; +var _Debug_log__PROD = F2(function (tag, value) { + return value; }); -var _Debug_log__DEBUG = F2(function(tag, value) -{ - console.log(tag + ': ' + _Debug_toString(value)); - return value; +var _Debug_log__DEBUG = F2(function (tag, value) { + console.log(tag + ": " + _Debug_toString(value)); + return value; }); - // TODOS -function _Debug_todo(moduleName, region) -{ - return function(message) { - _Debug_crash(8, moduleName, region, message); - }; +function _Debug_todo(moduleName, region) { + return function (message) { + _Debug_crash(8, moduleName, region, message); + }; } -function _Debug_todoCase(moduleName, region, value) -{ - return function(message) { - _Debug_crash(9, moduleName, region, value, message); - }; +function _Debug_todoCase(moduleName, region, value) { + return function (message) { + _Debug_crash(9, moduleName, region, value, message); + }; } - // TO STRING -function _Debug_toString__PROD(value) -{ - return ''; +function _Debug_toString__PROD(value) { + return ""; } -function _Debug_toString__DEBUG(value) -{ - return _Debug_toAnsiString(false, value); +function _Debug_toString__DEBUG(value) { + return _Debug_toAnsiString(false, value); } -function _Debug_toAnsiString(ansi, value) -{ - if (typeof value === 'function') - { - return _Debug_internalColor(ansi, ''); - } - - if (typeof value === 'boolean') - { - return _Debug_ctorColor(ansi, value ? 'True' : 'False'); - } - - if (typeof value === 'number') - { - return _Debug_numberColor(ansi, value + ''); - } - - if (value instanceof String) - { - return _Debug_charColor(ansi, "'" + _Debug_addSlashes(value, true) + "'"); - } - - if (typeof value === 'string') - { - return _Debug_stringColor(ansi, '"' + _Debug_addSlashes(value, false) + '"'); - } - - if (typeof value === 'object' && '$' in value) - { - var tag = value.$; - - if (typeof tag === 'number') - { - return _Debug_internalColor(ansi, ''); - } - - if (tag[0] === '#') - { - var output = []; - for (var k in value) - { - if (k === '$') continue; - output.push(_Debug_toAnsiString(ansi, value[k])); - } - return '(' + output.join(',') + ')'; - } - - if (tag === 'Set_elm_builtin') - { - return _Debug_ctorColor(ansi, 'Set') - + _Debug_fadeColor(ansi, '.fromList') + ' ' - + _Debug_toAnsiString(ansi, __Set_toList(value)); - } - - if (tag === 'RBNode_elm_builtin' || tag === 'RBEmpty_elm_builtin') - { - return _Debug_ctorColor(ansi, 'Dict') - + _Debug_fadeColor(ansi, '.fromList') + ' ' - + _Debug_toAnsiString(ansi, __Dict_toList(value)); - } - - if (tag === 'Array_elm_builtin') - { - return _Debug_ctorColor(ansi, 'Array') - + _Debug_fadeColor(ansi, '.fromList') + ' ' - + _Debug_toAnsiString(ansi, __Array_toList(value)); - } - - if (tag === 'Cons_elm_builtin' || tag === 'Nil_elm_builtin') - { - var output = '['; - - value.b && (output += _Debug_toAnsiString(ansi, value.a), value = value.b) - - for (; value.b; value = value.b) // WHILE_CONS - { - output += ',' + _Debug_toAnsiString(ansi, value.a); - } - return output + ']'; - } - - var output = ''; - for (var i in value) - { - if (i === '$') continue; - var str = _Debug_toAnsiString(ansi, value[i]); - var c0 = str[0]; - var parenless = c0 === '{' || c0 === '(' || c0 === '[' || c0 === '<' || c0 === '"' || str.indexOf(' ') < 0; - output += ' ' + (parenless ? str : '(' + str + ')'); - } - return _Debug_ctorColor(ansi, tag) + output; - } - - if (typeof DataView === 'function' && value instanceof DataView) - { - return _Debug_stringColor(ansi, '<' + value.byteLength + ' bytes>'); - } - - if (typeof File !== 'undefined' && value instanceof File) - { - return _Debug_internalColor(ansi, '<' + value.name + '>'); - } - - if (typeof value === 'object') - { - var output = []; - for (var key in value) - { - var field = key[0] === '_' ? key.slice(1) : key; - output.push(_Debug_fadeColor(ansi, field) + ' = ' + _Debug_toAnsiString(ansi, value[key])); - } - if (output.length === 0) - { - return '{}'; - } - return '{ ' + output.join(', ') + ' }'; - } - - return _Debug_internalColor(ansi, ''); +function _Debug_toAnsiString(ansi, value) { + if (typeof value === "function") { + return _Debug_internalColor(ansi, ""); + } + + if (typeof value === "boolean") { + return _Debug_ctorColor(ansi, value ? "True" : "False"); + } + + if (typeof value === "number") { + return _Debug_numberColor(ansi, value + ""); + } + + if (value instanceof String) { + return _Debug_charColor(ansi, "'" + _Debug_addSlashes(value, true) + "'"); + } + + if (typeof value === "string") { + return _Debug_stringColor(ansi, '"' + _Debug_addSlashes(value, false) + '"'); + } + + if (typeof value === "object" && "$" in value) { + var tag = value.$; + + if (typeof tag === "number") { + return _Debug_internalColor(ansi, ""); + } + + if (tag[0] === "#") { + var output = []; + for (var k in value) { + if (k === "$") continue; + output.push(_Debug_toAnsiString(ansi, value[k])); + } + return "(" + output.join(",") + ")"; + } + + if (tag === "Set_elm_builtin") { + return ( + _Debug_ctorColor(ansi, "Set") + + _Debug_fadeColor(ansi, ".fromList") + + " " + + _Debug_toAnsiString(ansi, __Set_toList(value)) + ); + } + + if (tag === "RBNode_elm_builtin" || tag === "RBEmpty_elm_builtin") { + return ( + _Debug_ctorColor(ansi, "Dict") + + _Debug_fadeColor(ansi, ".fromList") + + " " + + _Debug_toAnsiString(ansi, __Dict_toList(value)) + ); + } + + if (tag === "Array_elm_builtin") { + return ( + _Debug_ctorColor(ansi, "Array") + + _Debug_fadeColor(ansi, ".fromList") + + " " + + _Debug_toAnsiString(ansi, __Array_toList(value)) + ); + } + + if (tag === "Cons_elm_builtin" || tag === "Nil_elm_builtin") { + var output = "["; + + value.b && ((output += _Debug_toAnsiString(ansi, value.a)), (value = value.b)); + + for ( + ; + value.b; + value = value.b // WHILE_CONS + ) { + output += "," + _Debug_toAnsiString(ansi, value.a); + } + return output + "]"; + } + + var output = ""; + for (var i in value) { + if (i === "$") continue; + var str = _Debug_toAnsiString(ansi, value[i]); + var c0 = str[0]; + var parenless = + c0 === "{" || c0 === "(" || c0 === "[" || c0 === "<" || c0 === '"' || str.indexOf(" ") < 0; + output += " " + (parenless ? str : "(" + str + ")"); + } + return _Debug_ctorColor(ansi, tag) + output; + } + + if (typeof DataView === "function" && value instanceof DataView) { + return _Debug_stringColor(ansi, "<" + value.byteLength + " bytes>"); + } + + if (typeof File !== "undefined" && value instanceof File) { + return _Debug_internalColor(ansi, "<" + value.name + ">"); + } + + if (typeof value === "object") { + var output = []; + for (var key in value) { + var field = key[0] === "_" ? key.slice(1) : key; + output.push(_Debug_fadeColor(ansi, field) + " = " + _Debug_toAnsiString(ansi, value[key])); + } + if (output.length === 0) { + return "{}"; + } + return "{ " + output.join(", ") + " }"; + } + + return _Debug_internalColor(ansi, ""); } -function _Debug_addSlashes(str, isChar) -{ - var s = str - .replace(/\\/g, '\\\\') - .replace(/\n/g, '\\n') - .replace(/\t/g, '\\t') - .replace(/\r/g, '\\r') - .replace(/\v/g, '\\v') - .replace(/\0/g, '\\0'); - - if (isChar) - { - return s.replace(/\'/g, '\\\''); - } - else - { - return s.replace(/\"/g, '\\"'); - } +function _Debug_addSlashes(str, isChar) { + var s = str + .replace(/\\/g, "\\\\") + .replace(/\n/g, "\\n") + .replace(/\t/g, "\\t") + .replace(/\r/g, "\\r") + .replace(/\v/g, "\\v") + .replace(/\0/g, "\\0"); + + if (isChar) { + return s.replace(/\'/g, "\\'"); + } else { + return s.replace(/\"/g, '\\"'); + } } -function _Debug_ctorColor(ansi, string) -{ - return ansi ? '\x1b[96m' + string + '\x1b[0m' : string; +function _Debug_ctorColor(ansi, string) { + return ansi ? "\x1b[96m" + string + "\x1b[0m" : string; } -function _Debug_numberColor(ansi, string) -{ - return ansi ? '\x1b[95m' + string + '\x1b[0m' : string; +function _Debug_numberColor(ansi, string) { + return ansi ? "\x1b[95m" + string + "\x1b[0m" : string; } -function _Debug_stringColor(ansi, string) -{ - return ansi ? '\x1b[93m' + string + '\x1b[0m' : string; +function _Debug_stringColor(ansi, string) { + return ansi ? "\x1b[93m" + string + "\x1b[0m" : string; } -function _Debug_charColor(ansi, string) -{ - return ansi ? '\x1b[92m' + string + '\x1b[0m' : string; +function _Debug_charColor(ansi, string) { + return ansi ? "\x1b[92m" + string + "\x1b[0m" : string; } -function _Debug_fadeColor(ansi, string) -{ - return ansi ? '\x1b[37m' + string + '\x1b[0m' : string; +function _Debug_fadeColor(ansi, string) { + return ansi ? "\x1b[37m" + string + "\x1b[0m" : string; } -function _Debug_internalColor(ansi, string) -{ - return ansi ? '\x1b[36m' + string + '\x1b[0m' : string; +function _Debug_internalColor(ansi, string) { + return ansi ? "\x1b[36m" + string + "\x1b[0m" : string; } -function _Debug_toHexDigit(n) -{ - return String.fromCharCode(n < 10 ? 48 + n : 55 + n); +function _Debug_toHexDigit(n) { + return String.fromCharCode(n < 10 ? 48 + n : 55 + n); } - // CRASH - function _Debug_runtimeCrashReason__PROD(reason) {} - function _Debug_runtimeCrashReason__DEBUG(reason) { - switch (reason) { - case 'subMap': - return function(fact2, fact3, fact4) { - throw new Error('Bug in elm runtime: attempting to subMap an effect from a command only effect module.'); - }; - - case 'cmdMap': - return function(fact2, fact3, fact4) { - throw new Error('Bug in elm runtime: attempting to cmdMap an effect from a subscription only effect module.'); - }; - - case 'procIdAlreadyRegistered': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); - }; - - case 'procIdNotRegistered': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: state for process ${fact2} been has not registered!`); - }; - - case 'cannotBeStepped': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!`); - }; - - case 'procIdAlreadyReady': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared`); - }; - - case 'subscriptionProcessMissing': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: expected there to be a subscriptionProcess with id ${fact2}.`); - }; - - case 'failedUnwrap': - return function(fact2, fact3, fact4) { - throw new Error(`Bug in elm runtime: trying to unwrap an new type but the js object had the following keys: ${Object.keys(fact2).join(', ')}`); - }; - } - throw new Error(`Unknown reason for runtime crash: ${fact1}!`); + switch (reason) { + case "subMap": + return function (fact2, fact3, fact4) { + throw new Error( + "Bug in elm runtime: attempting to subMap an effect from a command only effect module." + ); + }; + + case "cmdMap": + return function (fact2, fact3, fact4) { + throw new Error( + "Bug in elm runtime: attempting to cmdMap an effect from a subscription only effect module." + ); + }; + + case "procIdAlreadyRegistered": + return function (fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: state for process ${fact2} is already registered!`); + }; + + case "procIdNotRegistered": + return function (fact2, fact3, fact4) { + throw new Error(`Bug in elm runtime: state for process ${fact2} been has not registered!`); + }; + + case "cannotBeStepped": + return function (fact2, fact3, fact4) { + throw new Error( + `Bug in elm runtime: attempting to step process with id ${fact2} whilst it is processing an async action!` + ); + }; + + case "procIdAlreadyReady": + return function (fact2, fact3, fact4) { + throw new Error( + `Bug in elm runtime: process ${fact2} already has a ready flag set (with value ${fact3}). Refusing to reset the value before it is cleared` + ); + }; + + case "subscriptionProcessMissing": + return function (fact2, fact3, fact4) { + throw new Error( + `Bug in elm runtime: expected there to be a subscriptionProcess with id ${fact2}.` + ); + }; + + case "failedUnwrap": + return function (fact2, fact3, fact4) { + throw new Error( + `Bug in elm runtime: trying to unwrap an new type but the js object had the following keys: ${Object.keys( + fact2 + ).join(", ")}` + ); + }; + } + throw new Error(`Unknown reason for runtime crash: ${fact1}!`); } - -function _Debug_crash__PROD(identifier) -{ - throw new Error('https://github.com/elm/core/blob/1.0.0/hints/' + identifier + '.md'); +function _Debug_crash__PROD(identifier) { + throw new Error("https://github.com/elm/core/blob/1.0.0/hints/" + identifier + ".md"); } - -function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) -{ - switch(identifier) - { - case 0: - throw new Error('What node should I take over? In JavaScript I need something like:\n\n Elm.Main.init({\n node: document.getElementById("elm-node")\n })\n\nYou need to do this with any Browser.sandbox or Browser.element program.'); - - case 1: - throw new Error('Browser.application programs cannot handle URLs like this:\n\n ' + document.location.href + '\n\nWhat is the root? The root of your file system? Try looking at this program with `elm reactor` or some other server.'); - - case 2: - { - var jsonErrorString = fact1; - throw new Error('Problem with the flags given to your Elm program on initialization.\n\n' + jsonErrorString); - } - - case 3: - { - var portName = fact1; - throw new Error('There can only be one port named `' + portName + '`, but your program has multiple.'); - } - - case 4: - { - var portName = fact1; - var problem = fact2; - throw new Error('Trying to send an unexpected type of value through port `' + portName + '`:\n' + problem); - } - - case 5: - throw new Error('Trying to use `(==)` on functions.\nThere is no way to know if functions are "the same" in the Elm sense.\nRead more about this at https://package.elm-lang.org/packages/elm/core/latest/Basics#== which describes why it is this way and what the better version will look like.'); - - case 6: - { - var moduleName = fact1; - throw new Error('Your page is loading multiple Elm scripts with a module named ' + moduleName + '. Maybe a duplicate script is getting loaded accidentally? If not, rename one of them so I know which is which!'); - } - - case 8: - { - var moduleName = fact1; - var region = fact2; - var message = fact3; - throw new Error('TODO in module `' + moduleName + '` ' + _Debug_regionToString(region) + '\n\n' + message); - } - - case 9: - { - var moduleName = fact1; - var region = fact2; - var value = fact3; - var message = fact4; - throw new Error( - 'TODO in module `' + moduleName + '` from the `case` expression ' - + _Debug_regionToString(region) + '\n\nIt received the following value:\n\n ' - + _Debug_toString(value).replace('\n', '\n ') - + '\n\nBut the branch that handles it says:\n\n ' + message.replace('\n', '\n ') - ); - } - - case 10: - throw new Error('Bug in https://github.com/elm/virtual-dom/issues'); - - case 11: - throw new Error('Cannot perform mod 0. Division by zero error.'); - - case 12: - { - fact1(fact2, fact3, fact4); - throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); - } - } +function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) { + switch (identifier) { + case 0: + throw new Error( + 'What node should I take over? In JavaScript I need something like:\n\n Elm.Main.init({\n node: document.getElementById("elm-node")\n })\n\nYou need to do this with any Browser.sandbox or Browser.element program.' + ); + + case 1: + throw new Error( + "Browser.application programs cannot handle URLs like this:\n\n " + + document.location.href + + "\n\nWhat is the root? The root of your file system? Try looking at this program with `elm reactor` or some other server." + ); + + case 2: { + var jsonErrorString = fact1; + throw new Error( + "Problem with the flags given to your Elm program on initialization.\n\n" + jsonErrorString + ); + } + + case 3: { + var portName = fact1; + throw new Error( + "There can only be one port named `" + portName + "`, but your program has multiple." + ); + } + + case 4: { + var portName = fact1; + var problem = fact2; + throw new Error( + "Trying to send an unexpected type of value through port `" + portName + "`:\n" + problem + ); + } + + case 5: + throw new Error( + 'Trying to use `(==)` on functions.\nThere is no way to know if functions are "the same" in the Elm sense.\nRead more about this at https://package.elm-lang.org/packages/elm/core/latest/Basics#== which describes why it is this way and what the better version will look like.' + ); + + case 6: { + var moduleName = fact1; + throw new Error( + "Your page is loading multiple Elm scripts with a module named " + + moduleName + + ". Maybe a duplicate script is getting loaded accidentally? If not, rename one of them so I know which is which!" + ); + } + + case 8: { + var moduleName = fact1; + var region = fact2; + var message = fact3; + throw new Error( + "TODO in module `" + moduleName + "` " + _Debug_regionToString(region) + "\n\n" + message + ); + } + + case 9: { + var moduleName = fact1; + var region = fact2; + var value = fact3; + var message = fact4; + throw new Error( + "TODO in module `" + + moduleName + + "` from the `case` expression " + + _Debug_regionToString(region) + + "\n\nIt received the following value:\n\n " + + _Debug_toString(value).replace("\n", "\n ") + + "\n\nBut the branch that handles it says:\n\n " + + message.replace("\n", "\n ") + ); + } + + case 10: + throw new Error("Bug in https://github.com/elm/virtual-dom/issues"); + + case 11: + throw new Error("Cannot perform mod 0. Division by zero error."); + + case 12: { + fact1(fact2, fact3, fact4); + throw new Error(`Unknown bug in elm runtime tag: ${fact1}!`); + } + } } -function _Debug_regionToString(region) -{ - if (region.__$start.__$line === region.__$end.__$line) - { - return 'on line ' + region.__$start.__$line; - } - return 'on lines ' + region.__$start.__$line + ' through ' + region.__$end.__$line; +function _Debug_regionToString(region) { + if (region.__$start.__$line === region.__$end.__$line) { + return "on line " + region.__$start.__$line; + } + return "on lines " + region.__$start.__$line + " through " + region.__$end.__$line; } diff --git a/src/Elm/Kernel/JsArray.js b/src/Elm/Kernel/JsArray.js index deeafc32..61f06b26 100644 --- a/src/Elm/Kernel/JsArray.js +++ b/src/Elm/Kernel/JsArray.js @@ -4,153 +4,128 @@ import Elm.Kernel.Utils exposing (Tuple2) */ - var _JsArray_empty = []; -function _JsArray_singleton(value) -{ - return [value]; +function _JsArray_singleton(value) { + return [value]; } -function _JsArray_length(array) -{ - return array.length; +function _JsArray_length(array) { + return array.length; } -var _JsArray_initialize = F3(function(size, offset, func) -{ - var result = new Array(size); +var _JsArray_initialize = F3(function (size, offset, func) { + var result = new Array(size); - for (var i = 0; i < size; i++) - { - result[i] = func(offset + i); - } + for (var i = 0; i < size; i++) { + result[i] = func(offset + i); + } - return result; + return result; }); -var _JsArray_initializeFromList = F2(function (max, ls) -{ - var result = new Array(max); +var _JsArray_initializeFromList = F2(function (max, ls) { + var result = new Array(max); - for (var i = 0; i < max && ls.b; i++) - { - result[i] = ls.a; - ls = ls.b; - } + for (var i = 0; i < max && ls.b; i++) { + result[i] = ls.a; + ls = ls.b; + } - result.length = i; - return __Utils_Tuple2(result, ls); + result.length = i; + return __Utils_Tuple2(result, ls); }); -var _JsArray_unsafeGet = F2(function(index, array) -{ - return array[index]; +var _JsArray_unsafeGet = F2(function (index, array) { + return array[index]; }); -var _JsArray_unsafeSet = F3(function(index, value, array) -{ - var length = array.length; - var result = new Array(length); +var _JsArray_unsafeSet = F3(function (index, value, array) { + var length = array.length; + var result = new Array(length); - for (var i = 0; i < length; i++) - { - result[i] = array[i]; - } + for (var i = 0; i < length; i++) { + result[i] = array[i]; + } - result[index] = value; - return result; + result[index] = value; + return result; }); -var _JsArray_push = F2(function(value, array) -{ - var length = array.length; - var result = new Array(length + 1); +var _JsArray_push = F2(function (value, array) { + var length = array.length; + var result = new Array(length + 1); - for (var i = 0; i < length; i++) - { - result[i] = array[i]; - } + for (var i = 0; i < length; i++) { + result[i] = array[i]; + } - result[length] = value; - return result; + result[length] = value; + return result; }); -var _JsArray_foldl = F3(function(func, acc, array) -{ - var length = array.length; +var _JsArray_foldl = F3(function (func, acc, array) { + var length = array.length; - for (var i = 0; i < length; i++) - { - acc = A2(func, array[i], acc); - } + for (var i = 0; i < length; i++) { + acc = A2(func, array[i], acc); + } - return acc; + return acc; }); -var _JsArray_foldr = F3(function(func, acc, array) -{ - for (var i = array.length - 1; i >= 0; i--) - { - acc = A2(func, array[i], acc); - } +var _JsArray_foldr = F3(function (func, acc, array) { + for (var i = array.length - 1; i >= 0; i--) { + acc = A2(func, array[i], acc); + } - return acc; + return acc; }); -var _JsArray_map = F2(function(func, array) -{ - var length = array.length; - var result = new Array(length); +var _JsArray_map = F2(function (func, array) { + var length = array.length; + var result = new Array(length); - for (var i = 0; i < length; i++) - { - result[i] = func(array[i]); - } + for (var i = 0; i < length; i++) { + result[i] = func(array[i]); + } - return result; + return result; }); -var _JsArray_indexedMap = F3(function(func, offset, array) -{ - var length = array.length; - var result = new Array(length); +var _JsArray_indexedMap = F3(function (func, offset, array) { + var length = array.length; + var result = new Array(length); - for (var i = 0; i < length; i++) - { - result[i] = A2(func, offset + i, array[i]); - } + for (var i = 0; i < length; i++) { + result[i] = A2(func, offset + i, array[i]); + } - return result; + return result; }); -var _JsArray_slice = F3(function(from, to, array) -{ - return array.slice(from, to); +var _JsArray_slice = F3(function (from, to, array) { + return array.slice(from, to); }); -var _JsArray_appendN = F3(function(n, dest, source) -{ - var destLen = dest.length; - var itemsToCopy = n - destLen; +var _JsArray_appendN = F3(function (n, dest, source) { + var destLen = dest.length; + var itemsToCopy = n - destLen; - if (itemsToCopy > source.length) - { - itemsToCopy = source.length; - } + if (itemsToCopy > source.length) { + itemsToCopy = source.length; + } - var size = destLen + itemsToCopy; - var result = new Array(size); + var size = destLen + itemsToCopy; + var result = new Array(size); - for (var i = 0; i < destLen; i++) - { - result[i] = dest[i]; - } + for (var i = 0; i < destLen; i++) { + result[i] = dest[i]; + } - for (var i = 0; i < itemsToCopy; i++) - { - result[i + destLen] = source[i]; - } + for (var i = 0; i < itemsToCopy; i++) { + result[i + destLen] = source[i]; + } - return result; + return result; }); diff --git a/src/Elm/Kernel/List.js b/src/Elm/Kernel/List.js index c084a7e4..fad002f6 100644 --- a/src/Elm/Kernel/List.js +++ b/src/Elm/Kernel/List.js @@ -18,30 +18,30 @@ import List exposing (Nil_elm_builtin, Cons_elm_builtin) * */ const _List_nilKey__PROD = 0; -const _List_nilKey__DEBUG = 'Nil_elm_builtin'; +const _List_nilKey__DEBUG = "Nil_elm_builtin"; const _List_Nil = { $: _List_nilKey }; const _List_Cons = (hd, tl) => A2(__List_Cons_elm_builtin, hd, tl); -const _List_fromArray = arr => arr.reduceRight( - (out, val) => A2(__List_Cons_elm_builtin, val, out), - __List_Nil_elm_builtin -); +const _List_fromArray = (arr) => + arr.reduceRight((out, val) => A2(__List_Cons_elm_builtin, val, out), __List_Nil_elm_builtin); -const _List_toArray = xs => { - const out = []; - while (true) { - if (xs.$ === _List_nilKey) { - return out; - } - out.push(xs.a); - xs = xs.b; - } +const _List_toArray = (xs) => { + const out = []; + while (true) { + if (xs.$ === _List_nilKey) { + return out; + } + out.push(xs.a); + xs = xs.b; + } }; const _List_sortWith = F2((f, xs) => - _List_fromArray(_List_toArray(xs).sort((a, b) => { - const ord = A2(f, a, b); - return ord === __Basics_EQ ? 0 : ord === __Basics_LT ? -1 : 1; - })) + _List_fromArray( + _List_toArray(xs).sort((a, b) => { + const ord = A2(f, a, b); + return ord === __Basics_EQ ? 0 : ord === __Basics_LT ? -1 : 1; + }) + ) ); diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 658280b7..500e07b6 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -28,112 +28,104 @@ var _Platform_effectDispatchInProgress = false; // INITIALIZE A PROGRAM const _Platform_initialize = F3((flagDecoder, args, impl) => { - - // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value - // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a - const flagsResult = A2( - __Json_run, - flagDecoder, - __Json_wrap(args ? args['flags'] : undefined) - ); - - if (!__Result_isOk(flagsResult)) { - __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); - } - - const selfSenders = new Map(); - const ports = {}; - - const dispatch = (model, cmds) => { - _Platform_effectsQueue.push({ - __cmds: cmds, - __subs: impl.__$subscriptions(model), - }); - - if (_Platform_effectDispatchInProgress) { - return; - } - - _Platform_effectDispatchInProgress = true; - while (true) { - const fx = _Platform_effectsQueue.shift(); - if (fx === undefined) { - _Platform_effectDispatchInProgress = false; - return; - } - const dispatcher = A2( - __Platform_initializeHelperFunctions.__$dispatchEffects, - fx.__cmds, - fx.__subs, - ); - for (const [key, selfSender] of selfSenders.entries()) { - __RawScheduler_rawSpawn(A2(dispatcher, key, selfSender)); - } - } - } - - const sendToApp = F2((msg, viewMetadata) => { - const updateValue = A2(impl.__$update, msg, model); - model = updateValue.a - A2(stepper, model, viewMetadata); - dispatch(model, updateValue.b); - }); - - for (const init of _Platform_subscriptionInit) { - __RawScheduler_rawSpawn(init(__Utils_Tuple0)); - } - - selfSenders.set('000PlatformEffect', __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp)); - for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { - const managerChannel = __Channel_rawUnbounded(__Utils_Tuple0); - __RawScheduler_rawSpawn( - A5( - __Platform_initializeHelperFunctions.__$setupEffects, - sendToApp, - managerChannel.b, - effectManagerFunctions.__init, - effectManagerFunctions.__fullOnEffects, - effectManagerFunctions.__onSelfMsg - ) - ); - selfSenders.set(key, managerChannel.a); - } - for (const [key, {port}] of _Platform_outgoingPorts.entries()) { - ports[key] = port; - } - for (const [key, {port}] of _Platform_incomingPorts.entries()) { - ports[key] = port; - } - - const initValue = impl.__$init(flagsResult.a); - let model = initValue.a; - const stepper = A2(__Platform_initializeHelperFunctions.__$stepperBuilder, sendToApp, model); - - dispatch(model, initValue.b); - - return ports ? { ports } : {}; + // Elm.Kernel.Json.wrap : RawJsObject -> Json.Decode.Value + // Elm.Kernel.Json.run : Json.Decode.Decoder a -> Json.Decode.Value -> Result Json.Decode.Error a + const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args["flags"] : undefined)); + + if (!__Result_isOk(flagsResult)) { + __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); + } + + const selfSenders = new Map(); + const ports = {}; + + const dispatch = (model, cmds) => { + _Platform_effectsQueue.push({ + __cmds: cmds, + __subs: impl.__$subscriptions(model), + }); + + if (_Platform_effectDispatchInProgress) { + return; + } + + _Platform_effectDispatchInProgress = true; + while (true) { + const fx = _Platform_effectsQueue.shift(); + if (fx === undefined) { + _Platform_effectDispatchInProgress = false; + return; + } + const dispatcher = A2( + __Platform_initializeHelperFunctions.__$dispatchEffects, + fx.__cmds, + fx.__subs + ); + for (const [key, selfSender] of selfSenders.entries()) { + __RawScheduler_rawSpawn(A2(dispatcher, key, selfSender)); + } + } + }; + + const sendToApp = F2((msg, viewMetadata) => { + const updateValue = A2(impl.__$update, msg, model); + model = updateValue.a; + A2(stepper, model, viewMetadata); + dispatch(model, updateValue.b); + }); + + for (const init of _Platform_subscriptionInit) { + __RawScheduler_rawSpawn(init(__Utils_Tuple0)); + } + + selfSenders.set( + "000PlatformEffect", + __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp) + ); + for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { + const managerChannel = __Channel_rawUnbounded(__Utils_Tuple0); + __RawScheduler_rawSpawn( + A5( + __Platform_initializeHelperFunctions.__$setupEffects, + sendToApp, + managerChannel.b, + effectManagerFunctions.__init, + effectManagerFunctions.__fullOnEffects, + effectManagerFunctions.__onSelfMsg + ) + ); + selfSenders.set(key, managerChannel.a); + } + for (const [key, { port }] of _Platform_outgoingPorts.entries()) { + ports[key] = port; + } + for (const [key, { port }] of _Platform_incomingPorts.entries()) { + ports[key] = port; + } + + const initValue = impl.__$init(flagsResult.a); + let model = initValue.a; + const stepper = A2(__Platform_initializeHelperFunctions.__$stepperBuilder, sendToApp, model); + + dispatch(model, initValue.b); + + return ports ? { ports } : {}; }); - // TRACK PRELOADS // // This is used by code in elm/browser and elm/http // to register any HTTP requests that are triggered by init. // - var _Platform_preload; - -function _Platform_registerPreload(url) -{ - _Platform_preload.add(url); +function _Platform_registerPreload(url) { + _Platform_preload.add(url); } - // EFFECT MANAGERS - /* Called by compiler generated js when creating event mangers. * * This function will **always** be call right after page load like this: @@ -151,40 +143,39 @@ function _Platform_registerPreload(url) * _Platform_effectManagers['XXX'] = * _Platform_createManager($init, $onEffects, $onSelfMsg, $cmdMap, $subMap); */ -function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) -{ - if (typeof cmdMap !== 'function') { - // Subscription only effect module - return { - __cmdMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason('cmdMap'))), - __subMapper: subMap, - __init: init, - __fullOnEffects: F4(function(router, _cmds, subs, state) { - return A3(onEffects, router, subs, state); - }), - __onSelfMsg: onSelfMsg, - }; - } else if (typeof subMap !== 'function') { - // Command only effect module - return { - __cmdMapper: cmdMap, - __subMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason('subMap'))), - __init: init, - __fullOnEffects: F4(function(router, cmds, _subs, state) { - return A3(onEffects, router, cmds, state); - }), - __onSelfMsg: onSelfMsg - }; - } else { - // Command **and** subscription event manager - return { - __cmdMapper: cmdMap, - __subMapper: subMap, - __init: init, - __fullOnEffects: onEffects, - __onSelfMsg: onSelfMsg - }; - } +function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { + if (typeof cmdMap !== "function") { + // Subscription only effect module + return { + __cmdMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason("cmdMap"))), + __subMapper: subMap, + __init: init, + __fullOnEffects: F4(function (router, _cmds, subs, state) { + return A3(onEffects, router, subs, state); + }), + __onSelfMsg: onSelfMsg, + }; + } else if (typeof subMap !== "function") { + // Command only effect module + return { + __cmdMapper: cmdMap, + __subMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason("subMap"))), + __init: init, + __fullOnEffects: F4(function (router, cmds, _subs, state) { + return A3(onEffects, router, cmds, state); + }), + __onSelfMsg: onSelfMsg, + }; + } else { + // Command **and** subscription event manager + return { + __cmdMapper: cmdMap, + __subMapper: subMap, + __init: init, + __fullOnEffects: onEffects, + __onSelfMsg: onSelfMsg, + }; + } } // BAGS @@ -192,189 +183,169 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) /* Called by compiler generated js for event managers for the * `command` or `subscription` function within an event manager */ -const _Platform_leaf = home => value => { - const list = __List_Cons({ - __$home: home, - __$value: value - }, __List_Nil); - /**__DEBUG/ +const _Platform_leaf = (home) => (value) => { + const list = __List_Cons( + { + __$home: home, + __$value: value, + }, + __List_Nil + ); + /**__DEBUG/ return { $: 'Data', a: list, }; /**/ - /**__PROD/ + /**__PROD/ return list; /**/ }; - // PORTS - -function _Platform_checkPortName(name) -{ - if (_Platform_effectManagers[name]) - { - __Debug_crash(3, name) - } +function _Platform_checkPortName(name) { + if (_Platform_effectManagers[name]) { + __Debug_crash(3, name); + } } - -function _Platform_outgoingPort(name, converter) -{ - _Platform_checkPortName(name); - let subs = []; - const subscribe = callback => { - subs.push(callback); - }; - const unsubscribe = callback => { - // copy subs into a new array in case unsubscribe is called within - // a subscribed callback - subs = subs.slice(); - var index = subs.indexOf(callback); - if (index >= 0) - { - subs.splice(index, 1); - } - }; - const execSubscribers = payload => { - const value = __Json_unwrap(converter(payload)); - for (const sub of subs) - { - sub(value); - } - return __Utils_Tuple0; - } - _Platform_outgoingPorts.set(name, { - port: { - subscribe, - unsubscribe, - }, - }); - - return payload => A2( - _Platform_leaf, - '000PlatformEffect', - __Scheduler_execImpure(_ => { - execSubscribers(payload); - return __Maybe_Nothing; - }) - ); +function _Platform_outgoingPort(name, converter) { + _Platform_checkPortName(name); + let subs = []; + const subscribe = (callback) => { + subs.push(callback); + }; + const unsubscribe = (callback) => { + // copy subs into a new array in case unsubscribe is called within + // a subscribed callback + subs = subs.slice(); + var index = subs.indexOf(callback); + if (index >= 0) { + subs.splice(index, 1); + } + }; + const execSubscribers = (payload) => { + const value = __Json_unwrap(converter(payload)); + for (const sub of subs) { + sub(value); + } + return __Utils_Tuple0; + }; + _Platform_outgoingPorts.set(name, { + port: { + subscribe, + unsubscribe, + }, + }); + + return (payload) => + A2( + _Platform_leaf, + "000PlatformEffect", + __Scheduler_execImpure((_) => { + execSubscribers(payload); + return __Maybe_Nothing; + }) + ); } +function _Platform_incomingPort(name, converter) { + _Platform_checkPortName(name); -function _Platform_incomingPort(name, converter) -{ - _Platform_checkPortName(name); + const tuple = _Platform_createSubProcess(); + const key = tuple.a; + const sender = tuple.b; - const tuple = _Platform_createSubProcess(); - const key = tuple.a; - const sender = tuple.b; + function send(incomingValue) { + var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); - function send(incomingValue) - { - var result = A2(__Json_run, converter, __Json_wrap(incomingValue)); + __Result_isOk(result) || __Debug_crash(4, name, result.a); - __Result_isOk(result) || __Debug_crash(4, name, result.a); + var value = result.a; + A2(__Channel_rawSend, sender, value); + } - var value = result.a; - A2(__Channel_rawSend, sender, value); - } - - _Platform_incomingPorts.set( - name, - { - port: { - send, - }, - } - ); + _Platform_incomingPorts.set(name, { + port: { + send, + }, + }); - return tagger => A2( - _Platform_leaf, - '000PlatformEffect', - __Utils_Tuple2(key, tagger) - ); + return (tagger) => A2(_Platform_leaf, "000PlatformEffect", __Utils_Tuple2(key, tagger)); } - // Functions exported to elm const _Platform_subscriptionMap = new Map(); const _Platform_subscriptionInit = []; let _Platform_subscriptionProcessIds = 0; -const _Platform_createSubProcess = _ => { - const channel = __Channel_rawUnbounded(); - const key = { id: _Platform_subscriptionProcessIds++ }; - const msgHandler = msg => { - return __RawTask_execImpure(_ => { - const sendToApps = _Platform_subscriptionMap.get(key); - /**__DEBUG/ +const _Platform_createSubProcess = (_) => { + const channel = __Channel_rawUnbounded(); + const key = { id: _Platform_subscriptionProcessIds++ }; + const msgHandler = (msg) => { + return __RawTask_execImpure((_) => { + const sendToApps = _Platform_subscriptionMap.get(key); + /**__DEBUG/ if (sendToApps === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); } //*/ - for (const sendToApp of sendToApps) { - sendToApp(msg); - } - return __Utils_Tuple0; - }); - }; + for (const sendToApp of sendToApps) { + sendToApp(msg); + } + return __Utils_Tuple0; + }); + }; - const onSubEffects = _ => - A2( - __RawTask_andThen, - onSubEffects, - A2(__RawChannel_recv, msgHandler, channel.b), - ); + const onSubEffects = (_) => + A2(__RawTask_andThen, onSubEffects, A2(__RawChannel_recv, msgHandler, channel.b)); - _Platform_subscriptionMap.set(key, []); - _Platform_subscriptionInit.push(onSubEffects); + _Platform_subscriptionMap.set(key, []); + _Platform_subscriptionInit.push(onSubEffects); - return __Utils_Tuple2(key, channel.a); + return __Utils_Tuple2(key, channel.a); }; -const _Platform_resetSubscriptions = newSubs => __RawTask_execImpure(_ => { - for (const sendToApps of _Platform_subscriptionMap.values()) { - sendToApps.length = 0; - } - for (const tuple of __List_toArray(newSubs)) { - const key = tuple.a; - const sendToApp = tuple.b; - const sendToApps = _Platform_subscriptionMap.get(key); - /**__DEBUG/ +const _Platform_resetSubscriptions = (newSubs) => + __RawTask_execImpure((_) => { + for (const sendToApps of _Platform_subscriptionMap.values()) { + sendToApps.length = 0; + } + for (const tuple of __List_toArray(newSubs)) { + const key = tuple.a; + const sendToApp = tuple.b; + const sendToApps = _Platform_subscriptionMap.get(key); + /**__DEBUG/ if (sendToApps === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); } //*/ - sendToApps.push(sendToApp); - } - return __Utils_Tuple0; -}); - -const _Platform_effectManagerNameToString = name => name; - - -const _Platform_getCmdMapper = home => { - if (home === '000PlatformEffect') { - return __Effects_mapCommand; - } - return _Platform_effectManagers[home].__cmdMapper; + sendToApps.push(sendToApp); + } + return __Utils_Tuple0; + }); + +const _Platform_effectManagerNameToString = (name) => name; + +const _Platform_getCmdMapper = (home) => { + if (home === "000PlatformEffect") { + return __Effects_mapCommand; + } + return _Platform_effectManagers[home].__cmdMapper; }; - -const _Platform_getSubMapper = home => { - if (_Platform_incomingPorts.has(home)) { - return F2((tagger, finalTagger) => value => tagger(finalTagger(value))); - } - return _Platform_effectManagers[home].__subMapper; +const _Platform_getSubMapper = (home) => { + if (_Platform_incomingPorts.has(home)) { + return F2((tagger, finalTagger) => (value) => tagger(finalTagger(value))); + } + return _Platform_effectManagers[home].__subMapper; }; -const _Platform_wrapTask = task => __Platform_Task(task); +const _Platform_wrapTask = (task) => __Platform_Task(task); -const _Platform_wrapProcessId = processId => __Platform_ProcessId(processId); +const _Platform_wrapProcessId = (processId) => __Platform_ProcessId(processId); // EXPORT ELM MODULES // @@ -382,44 +353,32 @@ const _Platform_wrapProcessId = processId => __Platform_ProcessId(processId); // debug mode and (2) not pay for the bits needed for that in prod mode. // - -function _Platform_export__PROD(exports) -{ - scope['Elm'] - ? _Platform_mergeExportsProd(scope['Elm'], exports) - : scope['Elm'] = exports; +function _Platform_export__PROD(exports) { + scope["Elm"] ? _Platform_mergeExportsProd(scope["Elm"], exports) : (scope["Elm"] = exports); } - -function _Platform_mergeExportsProd(obj, exports) -{ - for (var name in exports) - { - (name in obj) - ? (name == 'init') - ? __Debug_crash(6) - : _Platform_mergeExportsProd(obj[name], exports[name]) - : (obj[name] = exports[name]); - } +function _Platform_mergeExportsProd(obj, exports) { + for (var name in exports) { + name in obj + ? name == "init" + ? __Debug_crash(6) + : _Platform_mergeExportsProd(obj[name], exports[name]) + : (obj[name] = exports[name]); + } } - -function _Platform_export__DEBUG(exports) -{ - scope['Elm'] - ? _Platform_mergeExportsDebug('Elm', scope['Elm'], exports) - : scope['Elm'] = exports; +function _Platform_export__DEBUG(exports) { + scope["Elm"] + ? _Platform_mergeExportsDebug("Elm", scope["Elm"], exports) + : (scope["Elm"] = exports); } - -function _Platform_mergeExportsDebug(moduleName, obj, exports) -{ - for (var name in exports) - { - (name in obj) - ? (name == 'init') - ? __Debug_crash(6, moduleName) - : _Platform_mergeExportsDebug(moduleName + '.' + name, obj[name], exports[name]) - : (obj[name] = exports[name]); - } +function _Platform_mergeExportsDebug(moduleName, obj, exports) { + for (var name in exports) { + name in obj + ? name == "init" + ? __Debug_crash(6, moduleName) + : _Platform_mergeExportsDebug(moduleName + "." + name, obj[name], exports[name]) + : (obj[name] = exports[name]); + } } diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index e1552161..d11b21fa 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -19,123 +19,129 @@ import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) * `RawScheduler.ProcessId`s for compatability with `elm/*` package code. */ -function _Scheduler_succeed(value) -{ - return __NiceScheduler_succeed(value); +function _Scheduler_succeed(value) { + return __NiceScheduler_succeed(value); } -function _Scheduler_binding(callback) -{ - return __NiceScheduler_binding(callback); +function _Scheduler_binding(callback) { + return __NiceScheduler_binding(callback); } -function _Scheduler_rawSpawn(task) -{ - return __NiceScheduler_rawSpawn(task); +function _Scheduler_rawSpawn(task) { + return __NiceScheduler_rawSpawn(task); } // SCHEDULER - var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); var _Scheduler_readyFlgs = new WeakMap(); function _Scheduler_getGuid() { - return _Scheduler_guid++; + return _Scheduler_guid++; } function _Scheduler_getProcessState(id) { - const procState = _Scheduler_processes.get(id); - /**__DEBUG/ + const procState = _Scheduler_processes.get(id); + /**__DEBUG/ if (procState === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('procIdNotRegistered'), id && id.a && id.a.__$id); } //*/ - return procState; + return procState; } - var _Scheduler_registerNewProcess = F2((procId, procState) => { - /**__DEBUG/ - if (_Scheduler_processes.has(procId)) { - __Debug_crash(12, __Debug_runtimeCrashReason('procIdAlreadyRegistered'), procId && procId.a && procId.a.__$id); - } - //*/ - _Scheduler_processes.set(procId, procState); - return procId; + /**__DEBUG/ + if (_Scheduler_processes.has(procId)) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("procIdAlreadyRegistered"), + procId && procId.a && procId.a.__$id + ); + } + //*/ + _Scheduler_processes.set(procId, procState); + return procId; }); - - -const _Scheduler_enqueueWithStepper = stepper => { - let working = false; - const queue = []; - - const stepProccessWithId = newProcId => { - const procState = _Scheduler_processes.get(newProcId); - /**__DEBUG/ - if (procState === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('procIdNotRegistered'), newProcId && newProcId.a && newProcId.a.__$id); - } - //*/ - const updatedState = A2(stepper, newProcId, procState); - /**__DEBUG/ - if (procState !== _Scheduler_processes.get(newProcId)) { - __Debug_crash(12, __Debug_runtimeCrashReason('reentrantProcUpdate'), newProcId && newProcId.a && newProcId.a.__$id); - } - //*/ - _Scheduler_processes.set(newProcId, updatedState); - }; - - return procId => { - /**__DEBUG/ - if (queue.some(p => p.a.__$id === procId.a.__$id)) { - __Debug_crash(12, __Debug_runtimeCrashReason('procIdAlreadyInQueue'), procId && procId.a && procId.a.__$id); - } - //*/ - queue.push(procId); - if (working) - { - return procId; - } - working = true; - while (true) - { - const newProcId = queue.shift(); - if (newProcId === undefined) { - working = false; - return procId; - } - stepProccessWithId(newProcId); - } - }; +const _Scheduler_enqueueWithStepper = (stepper) => { + let working = false; + const queue = []; + + const stepProccessWithId = (newProcId) => { + const procState = _Scheduler_processes.get(newProcId); + /**__DEBUG/ + if (procState === undefined) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("procIdNotRegistered"), + newProcId && newProcId.a && newProcId.a.__$id + ); + } + /**__DEBUG/ + const updatedState = A2(stepper, newProcId, procState); + /**/ + if (procState !== _Scheduler_processes.get(newProcId)) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("reentrantProcUpdate"), + newProcId && newProcId.a && newProcId.a.__$id + ); + } + //*/ + _Scheduler_processes.set(newProcId, updatedState); + }; + + return (procId) => { + /**__DEBUG/ + if (queue.some((p) => p.a.__$id === procId.a.__$id)) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("procIdAlreadyInQueue"), + procId && procId.a && procId.a.__$id + ); + } + //*/ + queue.push(procId); + if (working) { + return procId; + } + working = true; + while (true) { + const newProcId = queue.shift(); + if (newProcId === undefined) { + working = false; + return procId; + } + stepProccessWithId(newProcId); + } + }; }; +var _Scheduler_delay = F3(function (time, value, callback) { + var id = setTimeout(function () { + callback(value); + }, time); -var _Scheduler_delay = F3(function (time, value, callback) -{ - var id = setTimeout(function() { - callback(value); - }, time); - - return function(x) { clearTimeout(id); return x; }; + return function (x) { + clearTimeout(id); + return x; + }; }); - -const _Scheduler_getWokenValue = procId => { - const flag = _Scheduler_readyFlgs.get(procId); - if (flag === undefined) { - return __Maybe_Nothing; - } else { - _Scheduler_readyFlgs.delete(procId); - return __Maybe_Just(flag); - } +const _Scheduler_getWokenValue = (procId) => { + const flag = _Scheduler_readyFlgs.get(procId); + if (flag === undefined) { + return __Maybe_Nothing; + } else { + _Scheduler_readyFlgs.delete(procId); + return __Maybe_Just(flag); + } }; - const _Scheduler_setWakeTask = F2((procId, newRoot) => { - /**__DEBUG/ + /**__DEBUG/ if (_Scheduler_readyFlgs.has(procId)) { __Debug_crash( 12, @@ -145,7 +151,6 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { ); } //*/ - _Scheduler_readyFlgs.set(procId, newRoot); - return _Utils_Tuple0; + _Scheduler_readyFlgs.set(procId, newRoot); + return _Utils_Tuple0; }); - diff --git a/src/Elm/Kernel/String.js b/src/Elm/Kernel/String.js index 13f49318..82be3ae0 100644 --- a/src/Elm/Kernel/String.js +++ b/src/Elm/Kernel/String.js @@ -7,313 +7,253 @@ import List exposing (Nil_elm_builtin) */ - -var _String_cons = F2(function(chr, str) -{ - return chr + str; +var _String_cons = F2(function (chr, str) { + return chr + str; }); -function _String_uncons(string) -{ - var word = string.charCodeAt(0); - return !isNaN(word) - ? __Maybe_Just( - 0xD800 <= word && word <= 0xDBFF - ? __Utils_Tuple2(__Utils_chr(string[0] + string[1]), string.slice(2)) - : __Utils_Tuple2(__Utils_chr(string[0]), string.slice(1)) - ) - : __Maybe_Nothing; +function _String_uncons(string) { + var word = string.charCodeAt(0); + return !isNaN(word) + ? __Maybe_Just( + 0xd800 <= word && word <= 0xdbff + ? __Utils_Tuple2(__Utils_chr(string[0] + string[1]), string.slice(2)) + : __Utils_Tuple2(__Utils_chr(string[0]), string.slice(1)) + ) + : __Maybe_Nothing; } -var _String_append = F2(function(a, b) -{ - return a + b; +var _String_append = F2(function (a, b) { + return a + b; }); -function _String_length(str) -{ - return str.length; +function _String_length(str) { + return str.length; } -var _String_map = F2(function(func, string) -{ - var len = string.length; - var array = new Array(len); - var i = 0; - while (i < len) - { - var word = string.charCodeAt(i); - if (0xD800 <= word && word <= 0xDBFF) - { - array[i] = func(__Utils_chr(string[i] + string[i+1])); - i += 2; - continue; - } - array[i] = func(__Utils_chr(string[i])); - i++; - } - return array.join(''); +var _String_map = F2(function (func, string) { + var len = string.length; + var array = new Array(len); + var i = 0; + while (i < len) { + var word = string.charCodeAt(i); + if (0xd800 <= word && word <= 0xdbff) { + array[i] = func(__Utils_chr(string[i] + string[i + 1])); + i += 2; + continue; + } + array[i] = func(__Utils_chr(string[i])); + i++; + } + return array.join(""); }); -var _String_filter = F2(function(isGood, str) -{ - var arr = []; - var len = str.length; - var i = 0; - while (i < len) - { - var char = str[i]; - var word = str.charCodeAt(i); - i++; - if (0xD800 <= word && word <= 0xDBFF) - { - char += str[i]; - i++; - } - - if (isGood(__Utils_chr(char))) - { - arr.push(char); - } - } - return arr.join(''); +var _String_filter = F2(function (isGood, str) { + var arr = []; + var len = str.length; + var i = 0; + while (i < len) { + var char = str[i]; + var word = str.charCodeAt(i); + i++; + if (0xd800 <= word && word <= 0xdbff) { + char += str[i]; + i++; + } + + if (isGood(__Utils_chr(char))) { + arr.push(char); + } + } + return arr.join(""); }); -function _String_reverse(str) -{ - var len = str.length; - var arr = new Array(len); - var i = 0; - while (i < len) - { - var word = str.charCodeAt(i); - if (0xD800 <= word && word <= 0xDBFF) - { - arr[len - i] = str[i + 1]; - i++; - arr[len - i] = str[i - 1]; - i++; - } - else - { - arr[len - i] = str[i]; - i++; - } - } - return arr.join(''); +function _String_reverse(str) { + var len = str.length; + var arr = new Array(len); + var i = 0; + while (i < len) { + var word = str.charCodeAt(i); + if (0xd800 <= word && word <= 0xdbff) { + arr[len - i] = str[i + 1]; + i++; + arr[len - i] = str[i - 1]; + i++; + } else { + arr[len - i] = str[i]; + i++; + } + } + return arr.join(""); } -var _String_foldl = F3(function(func, state, string) -{ - var len = string.length; - var i = 0; - while (i < len) - { - var char = string[i]; - var word = string.charCodeAt(i); - i++; - if (0xD800 <= word && word <= 0xDBFF) - { - char += string[i]; - i++; - } - state = A2(func, __Utils_chr(char), state); - } - return state; +var _String_foldl = F3(function (func, state, string) { + var len = string.length; + var i = 0; + while (i < len) { + var char = string[i]; + var word = string.charCodeAt(i); + i++; + if (0xd800 <= word && word <= 0xdbff) { + char += string[i]; + i++; + } + state = A2(func, __Utils_chr(char), state); + } + return state; }); -var _String_foldr = F3(function(func, state, string) -{ - var i = string.length; - while (i--) - { - var char = string[i]; - var word = string.charCodeAt(i); - if (0xDC00 <= word && word <= 0xDFFF) - { - i--; - char = string[i] + char; - } - state = A2(func, __Utils_chr(char), state); - } - return state; +var _String_foldr = F3(function (func, state, string) { + var i = string.length; + while (i--) { + var char = string[i]; + var word = string.charCodeAt(i); + if (0xdc00 <= word && word <= 0xdfff) { + i--; + char = string[i] + char; + } + state = A2(func, __Utils_chr(char), state); + } + return state; }); -var _String_split = F2(function(sep, str) -{ - return str.split(sep); +var _String_split = F2(function (sep, str) { + return str.split(sep); }); -var _String_join = F2(function(sep, strs) -{ - return strs.join(sep); +var _String_join = F2(function (sep, strs) { + return strs.join(sep); }); -var _String_slice = F3(function(start, end, str) { - return str.slice(start, end); +var _String_slice = F3(function (start, end, str) { + return str.slice(start, end); }); -function _String_trim(str) -{ - return str.trim(); +function _String_trim(str) { + return str.trim(); } -function _String_trimLeft(str) -{ - return str.replace(/^\s+/, ''); +function _String_trimLeft(str) { + return str.replace(/^\s+/, ""); } -function _String_trimRight(str) -{ - return str.replace(/\s+$/, ''); +function _String_trimRight(str) { + return str.replace(/\s+$/, ""); } -function _String_words(str) -{ - return __List_fromArray(str.trim().split(/\s+/g)); +function _String_words(str) { + return __List_fromArray(str.trim().split(/\s+/g)); } -function _String_lines(str) -{ - return __List_fromArray(str.split(/\r\n|\r|\n/g)); +function _String_lines(str) { + return __List_fromArray(str.split(/\r\n|\r|\n/g)); } -function _String_toUpper(str) -{ - return str.toUpperCase(); +function _String_toUpper(str) { + return str.toUpperCase(); } -function _String_toLower(str) -{ - return str.toLowerCase(); +function _String_toLower(str) { + return str.toLowerCase(); } -var _String_any = F2(function(isGood, string) -{ - var i = string.length; - while (i--) - { - var char = string[i]; - var word = string.charCodeAt(i); - if (0xDC00 <= word && word <= 0xDFFF) - { - i--; - char = string[i] + char; - } - if (isGood(__Utils_chr(char))) - { - return true; - } - } - return false; +var _String_any = F2(function (isGood, string) { + var i = string.length; + while (i--) { + var char = string[i]; + var word = string.charCodeAt(i); + if (0xdc00 <= word && word <= 0xdfff) { + i--; + char = string[i] + char; + } + if (isGood(__Utils_chr(char))) { + return true; + } + } + return false; }); -var _String_all = F2(function(isGood, string) -{ - var i = string.length; - while (i--) - { - var char = string[i]; - var word = string.charCodeAt(i); - if (0xDC00 <= word && word <= 0xDFFF) - { - i--; - char = string[i] + char; - } - if (!isGood(__Utils_chr(char))) - { - return false; - } - } - return true; +var _String_all = F2(function (isGood, string) { + var i = string.length; + while (i--) { + var char = string[i]; + var word = string.charCodeAt(i); + if (0xdc00 <= word && word <= 0xdfff) { + i--; + char = string[i] + char; + } + if (!isGood(__Utils_chr(char))) { + return false; + } + } + return true; }); -var _String_contains = F2(function(sub, str) -{ - return str.indexOf(sub) > -1; +var _String_contains = F2(function (sub, str) { + return str.indexOf(sub) > -1; }); -var _String_startsWith = F2(function(sub, str) -{ - return str.indexOf(sub) === 0; +var _String_startsWith = F2(function (sub, str) { + return str.indexOf(sub) === 0; }); -var _String_endsWith = F2(function(sub, str) -{ - return str.length >= sub.length && - str.lastIndexOf(sub) === str.length - sub.length; +var _String_endsWith = F2(function (sub, str) { + return str.length >= sub.length && str.lastIndexOf(sub) === str.length - sub.length; }); -var _String_indexes = F2(function(sub, str) -{ - var subLen = sub.length; +var _String_indexes = F2(function (sub, str) { + var subLen = sub.length; - if (subLen < 1) - { - return __List_Nil_elm_builtin; - } + if (subLen < 1) { + return __List_Nil_elm_builtin; + } - var i = 0; - var is = []; + var i = 0; + var is = []; - while ((i = str.indexOf(sub, i)) > -1) - { - is.push(i); - i = i + subLen; - } + while ((i = str.indexOf(sub, i)) > -1) { + is.push(i); + i = i + subLen; + } - return __List_fromArray(is); + return __List_fromArray(is); }); - // TO STRING -function _String_fromNumber(number) -{ - return number + ''; +function _String_fromNumber(number) { + return number + ""; } - // INT CONVERSIONS -function _String_toInt(str) -{ - var total = 0; - var code0 = str.charCodeAt(0); - var start = code0 == 0x2B /* + */ || code0 == 0x2D /* - */ ? 1 : 0; - - for (var i = start; i < str.length; ++i) - { - var code = str.charCodeAt(i); - if (code < 0x30 || 0x39 < code) - { - return __Maybe_Nothing; - } - total = 10 * total + code - 0x30; - } - - return i == start - ? __Maybe_Nothing - : __Maybe_Just(code0 == 0x2D ? -total : total); -} +function _String_toInt(str) { + var total = 0; + var code0 = str.charCodeAt(0); + var start = code0 == 0x2b /* + */ || code0 == 0x2d /* - */ ? 1 : 0; + for (var i = start; i < str.length; ++i) { + var code = str.charCodeAt(i); + if (code < 0x30 || 0x39 < code) { + return __Maybe_Nothing; + } + total = 10 * total + code - 0x30; + } + + return i == start ? __Maybe_Nothing : __Maybe_Just(code0 == 0x2d ? -total : total); +} // FLOAT CONVERSIONS -function _String_toFloat(s) -{ - // check if it is a hex, octal, or binary number - if (s.length === 0 || /[\sxbo]/.test(s)) - { - return __Maybe_Nothing; - } - var n = +s; - // faster isNaN check - return n === n ? __Maybe_Just(n) : __Maybe_Nothing; +function _String_toFloat(s) { + // check if it is a hex, octal, or binary number + if (s.length === 0 || /[\sxbo]/.test(s)) { + return __Maybe_Nothing; + } + var n = +s; + // faster isNaN check + return n === n ? __Maybe_Just(n) : __Maybe_Nothing; } -function _String_fromList(chars) -{ - return __List_toArray(chars).join(''); +function _String_fromList(chars) { + return __List_toArray(chars).join(""); } - diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index e2409d3b..00a32b2d 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -10,79 +10,70 @@ import List exposing (append) */ - // EQUALITY const _Utils_eq = (x, y) => { - const stack = []; - while(_Utils_eqHelp(x, y, 0, stack)) { - const pair = stack.pop(); - if (pair === undefined) { - return true; - } - [x, y] = pair; - } - return false; -} - -function _Utils_eqHelp(x, y, depth, stack) -{ - if (x === y) - { - return true; - } - - if (typeof x !== 'object' || x === null || y === null) - { - if (typeof x === 'function') { - __Debug_crash(5); - } - return false; - } - - if (depth > 100) - { - stack.push([x,y]); - return true; - } - - /**__DEBUG/ - if (x.$ === 'Set_elm_builtin') - { - x = __Set_toList(x); - y = __Set_toList(y); - } - if (x.$ === 'RBNode_elm_builtin' || x.$ === 'RBEmpty_elm_builtin') - { - x = __Dict_toList(x); - y = __Dict_toList(y); - } - //*/ - - /**__PROD/ - if (x.$ < 0) - { - x = __Dict_toList(x); - y = __Dict_toList(y); - } - //*/ - - /* The compiler ensures that the elm types of x and y are the same. - * Therefore, x and y must have the same keys. - */ - for (const key of Object.keys(x)) - { - if (!_Utils_eqHelp(x[key], y[key], depth + 1, stack)) { - return false; - } - } - return true; + const stack = []; + while (_Utils_eqHelp(x, y, 0, stack)) { + const pair = stack.pop(); + if (pair === undefined) { + return true; + } + [x, y] = pair; + } + return false; +}; + +function _Utils_eqHelp(x, y, depth, stack) { + if (x === y) { + return true; + } + + if (typeof x !== "object" || x === null || y === null) { + if (typeof x === "function") { + __Debug_crash(5); + } + return false; + } + + if (depth > 100) { + stack.push([x, y]); + return true; + } + + /**__DEBUG/ + if (x.$ === "Set_elm_builtin") { + x = __Set_toList(x); + y = __Set_toList(y); + } + if (x.$ === "RBNode_elm_builtin" || x.$ === "RBEmpty_elm_builtin") { + x = __Dict_toList(x); + y = __Dict_toList(y); + } + //*/ + + /**__DEBUG/ + if (x.$ < 0) { + x = __Dict_toList(x); + y = __Dict_toList(y); + } + //*/ + + /* The compiler ensures that the elm types of x and y are the same. + * Therefore, x and y must have the same keys. + */ + for (const key of Object.keys(x)) { + if (!_Utils_eqHelp(x[key], y[key], depth + 1, stack)) { + return false; + } + } + return true; } const _Utils_equal = F2(_Utils_eq); -const _Utils_notEqual = F2(function(a, b) { return !_Utils_eq(a,b); }); - - +const _Utils_notEqual = F2(function (a, b) { + return !_Utils_eq(a, b); +}); // COMPARISONS @@ -90,64 +81,61 @@ const _Utils_notEqual = F2(function(a, b) { return !_Utils_eq(a,b); }); // particular integer values assigned to LT, EQ, and GT. Comparable types are: // numbers, characters, strings, lists of comparable things, and tuples of // comparable things. -function _Utils_cmp(x, y, ord) -{ - // Handle numbers, strings and characters in production mode. - if (typeof x !== 'object') - { - return x === y ? /*EQ*/ 0 : x < y ? /*LT*/ -1 : /*GT*/ 1; - } - - // Handle characters in debug mode. - /**__DEBUG/ - if (x instanceof String) - { - var a = x.valueOf(); - var b = y.valueOf(); - return a === b ? 0 : a < b ? -1 : 1; - } - //*/ - - // Handle tuples. - /**__PROD/ +function _Utils_cmp(x, y, ord) { + // Handle numbers, strings and characters in production mode. + if (typeof x !== "object") { + return x === y ? /*EQ*/ 0 : x < y ? /*LT*/ -1 : /*GT*/ 1; + } + + // Handle characters in debug mode. + /**__DEBUG/ + if (x instanceof String) { + var a = x.valueOf(); + var b = y.valueOf(); + return a === b ? 0 : a < b ? -1 : 1; + } + //*/ + + // Handle tuples. + /**__PROD/ if (typeof x.$ === 'undefined') //*/ - /**__DEBUG/ + /**__DEBUG/ if (x.$[0] === '#') //*/ - { - const ordA = _Utils_cmp(x.a, y.a); - if (ordA !== 0) { - return ordA; - } - const ordB = _Utils_cmp(x.a, y.a); - if (ordB !== 0) { - return ordB; - } - return _Utils_cmp(x.c, y.c); - } - - // Handle lists: traverse conses until end of a list or a mismatch. If the - // all the elements in one list are equal to all the elements in other list - // but the first list is longer than the first list is greater (and visa - // versa). - while(true) { - if (x.$ === _List_nilKey) { - if (y.$ === _List_nilKey) { - return 0; - } else { - return -1; - } - } else if (y.$ === _List_nilKey) { - return 1; - } - const ord = _Utils_cmp(x.a, y.a); - if (ord !== 0) { - return ord; - } - x = x.b; - y = y.b; - } + { + const ordA = _Utils_cmp(x.a, y.a); + if (ordA !== 0) { + return ordA; + } + const ordB = _Utils_cmp(x.a, y.a); + if (ordB !== 0) { + return ordB; + } + return _Utils_cmp(x.c, y.c); + } + + // Handle lists: traverse conses until end of a list or a mismatch. If the + // all the elements in one list are equal to all the elements in other list + // but the first list is longer than the first list is greater (and visa + // versa). + while (true) { + if (x.$ === _List_nilKey) { + if (y.$ === _List_nilKey) { + return 0; + } else { + return -1; + } + } else if (y.$ === _List_nilKey) { + return 1; + } + const ord = _Utils_cmp(x.a, y.a); + if (ord !== 0) { + return ord; + } + x = x.b; + y = y.b; + } } const _Utils_compare = F2((x, y) => _Utils_cmp(x, y)); @@ -155,35 +143,29 @@ const _Utils_compare = F2((x, y) => _Utils_cmp(x, y)); // COMMON VALUES const _Utils_Tuple0__PROD = 0; -const _Utils_Tuple0__DEBUG = { $: '#0' }; +const _Utils_Tuple0__DEBUG = { $: "#0" }; const _Utils_Tuple2__PROD = (a, b) => ({ a, b }); -const _Utils_Tuple2__DEBUG = (a, b) => ({ $: '#2', a, b }); +const _Utils_Tuple2__DEBUG = (a, b) => ({ $: "#2", a, b }); const _Utils_Tuple3__PROD = (a, b, c) => ({ a, b, c }); -const _Utils_Tuple3__DEBUG = (a, b, c) => ({ $: '#3', a, b, c }); - -const _Utils_chr__PROD = c => c; -const _Utils_chr__DEBUG = c => new String(c); +const _Utils_Tuple3__DEBUG = (a, b, c) => ({ $: "#3", a, b, c }); +const _Utils_chr__PROD = (c) => c; +const _Utils_chr__DEBUG = (c) => new String(c); // RECORDS -const _Utils_update = (oldRecord, updatedFields) => Object.assign( - {}, - oldRecord, - updatedFields); - +const _Utils_update = (oldRecord, updatedFields) => Object.assign({}, oldRecord, updatedFields); // APPEND const _Utils_ap = (xs, ys) => { - // append Strings - if (typeof xs === 'string') - { - return xs + ys; - } - - // append Lists - return A2(__List_append, xs, ys); -} + // append Strings + if (typeof xs === "string") { + return xs + ys; + } + + // append Lists + return A2(__List_append, xs, ys); +}; From 3009818cda36dc6e8a7c3eec9c6e97dc17cf620f Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 21:08:25 +0100 Subject: [PATCH 131/170] fix typo introduced whilst prettying --- src/Elm/Kernel/Utils.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index 00a32b2d..c25a763a 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -52,7 +52,7 @@ function _Utils_eqHelp(x, y, depth, stack) { } //*/ - /**__DEBUG/ + /**__PROD/ if (x.$ < 0) { x = __Dict_toList(x); y = __Dict_toList(y); From 1006dd7d8847586678795bc8ca929e1e2d340ce0 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 21:50:38 +0100 Subject: [PATCH 132/170] create isDebug abstraction --- src/Elm/Kernel/Basics.js | 3 +++ src/Elm/Kernel/Channel.js | 38 ++++++++++++++++++------------ src/Elm/Kernel/Platform.js | 33 +++++++++++++------------- src/Elm/Kernel/Scheduler.js | 25 ++++++-------------- src/Elm/Kernel/Utils.js | 47 +++++++++++++++---------------------- 5 files changed, 68 insertions(+), 78 deletions(-) diff --git a/src/Elm/Kernel/Basics.js b/src/Elm/Kernel/Basics.js index 28683356..eed99a32 100644 --- a/src/Elm/Kernel/Basics.js +++ b/src/Elm/Kernel/Basics.js @@ -39,3 +39,6 @@ const _Basics_unwrapTypeWrapper__DEBUG = (wrapped) => { }; const _Basics_unwrapTypeWrapper__PROD = (wrapped) => wrapped; + +const _Basics_isDebug__DEBUG = true; +const _Basics_isDebug__PROD = false; diff --git a/src/Elm/Kernel/Channel.js b/src/Elm/Kernel/Channel.js index 67c1cdf6..fea0aa78 100644 --- a/src/Elm/Kernel/Channel.js +++ b/src/Elm/Kernel/Channel.js @@ -1,6 +1,7 @@ /* import Maybe exposing (Just, Nothing) +import Elm.Kernel.Basics exposing (isDebug) import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Utils exposing (Tuple2) */ @@ -21,11 +22,14 @@ const _Channel_rawUnbounded = (_) => { const _Channel_rawTryRecv = (channelId) => { const channel = _Channel_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); - } - //*/ + if (__Basics_isDebug && channel === undefined) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("channelIdNotRegistered"), + channelId && channelId.a && channelId.a.__$id + ); + } + const msg = channel.messages.shift(); if (msg === undefined) { return __Maybe_Nothing; @@ -36,11 +40,13 @@ const _Channel_rawTryRecv = (channelId) => { const _Channel_rawRecv = F2((channelId, onMsg) => { const channel = _Channel_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); - } - //*/ + if (__Basics_isDebug && channel === undefined) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("channelIdNotRegistered"), + channelId && channelId.a && channelId.a.__$id + ); + } const msg = channel.messages.shift(); if (msg !== undefined) { onMsg(msg); @@ -58,11 +64,13 @@ const _Channel_rawRecv = F2((channelId, onMsg) => { const _Channel_rawSendImpl = F2((channelId, msg) => { const channel = _Channel_channels.get(channelId); - /**__DEBUG/ - if (channel === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('channelIdNotRegistered'), channelId && channelId.a && channelId.a.__$id); - } - //*/ + if (__Basics_isDebug && channel === undefined) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("channelIdNotRegistered"), + channelId && channelId.a && channelId.a.__$id + ); + } const wakerIter = channel.wakers[Symbol.iterator](); const { value: nextWaker, done } = wakerIter.next(); diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 500e07b6..ac39cbf6 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -5,6 +5,7 @@ import Elm.Kernel.Json exposing (run, wrap, unwrap, errorToString) import Elm.Kernel.List exposing (Cons, Nil, toArray) import Elm.Kernel.Utils exposing (Tuple0, Tuple2) import Elm.Kernel.Channel exposing (rawUnbounded, rawSend) +import Elm.Kernel.Basics exposing (isDebug) import Result exposing (isOk) import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId, initializeHelperFunctions) @@ -33,7 +34,11 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args["flags"] : undefined)); if (!__Result_isOk(flagsResult)) { - __Debug_crash(2 /**__DEBUG/, __Json_errorToString(result.a) /**/); + if (__Basics_isDebug) { + __Debug_crash(2, __Json_errorToString(result.a)); + } else { + __Debug_crash(2); + } } const selfSenders = new Map(); @@ -191,15 +196,13 @@ const _Platform_leaf = (home) => (value) => { }, __List_Nil ); - /**__DEBUG/ - return { - $: 'Data', - a: list, - }; - /**/ - /**__PROD/ + if (__Basics_isDebug) { + return { + $: 'Data', + a: list, + }; + } return list; - /**/ }; // PORTS @@ -287,11 +290,9 @@ const _Platform_createSubProcess = (_) => { const msgHandler = (msg) => { return __RawTask_execImpure((_) => { const sendToApps = _Platform_subscriptionMap.get(key); - /**__DEBUG/ - if (sendToApps === undefined) { + if (__Basics_isDebug && sendToApps === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); } - //*/ for (const sendToApp of sendToApps) { sendToApp(msg); } @@ -317,11 +318,9 @@ const _Platform_resetSubscriptions = (newSubs) => const key = tuple.a; const sendToApp = tuple.b; const sendToApps = _Platform_subscriptionMap.get(key); - /**__DEBUG/ - if (sendToApps === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); - } - //*/ + if (__Basics_isDebug && sendToApps === undefined) { + __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); + } sendToApps.push(sendToApp); } return __Utils_Tuple0; diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index d11b21fa..cec81048 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -3,6 +3,7 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) import Maybe exposing (Just, Nothing) import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) +import Elm.Kernel.Basics exposing (isDebug) */ // COMPATIBILITY @@ -43,24 +44,20 @@ function _Scheduler_getGuid() { function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); - /**__DEBUG/ - if (procState === undefined) { + if (__Basics_isDebug && procState === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason('procIdNotRegistered'), id && id.a && id.a.__$id); } - //*/ return procState; } var _Scheduler_registerNewProcess = F2((procId, procState) => { - /**__DEBUG/ - if (_Scheduler_processes.has(procId)) { + if (__Basics_isDebug && _Scheduler_processes.has(procId)) { __Debug_crash( 12, __Debug_runtimeCrashReason("procIdAlreadyRegistered"), procId && procId.a && procId.a.__$id ); } - //*/ _Scheduler_processes.set(procId, procState); return procId; }); @@ -71,38 +68,32 @@ const _Scheduler_enqueueWithStepper = (stepper) => { const stepProccessWithId = (newProcId) => { const procState = _Scheduler_processes.get(newProcId); - /**__DEBUG/ - if (procState === undefined) { + if (__Basics_isDebug && procState === undefined) { __Debug_crash( 12, __Debug_runtimeCrashReason("procIdNotRegistered"), newProcId && newProcId.a && newProcId.a.__$id ); } - /**__DEBUG/ const updatedState = A2(stepper, newProcId, procState); - /**/ - if (procState !== _Scheduler_processes.get(newProcId)) { + if (__Basics_isDebug && procState !== _Scheduler_processes.get(newProcId)) { __Debug_crash( 12, __Debug_runtimeCrashReason("reentrantProcUpdate"), newProcId && newProcId.a && newProcId.a.__$id ); } - //*/ _Scheduler_processes.set(newProcId, updatedState); }; return (procId) => { - /**__DEBUG/ - if (queue.some((p) => p.a.__$id === procId.a.__$id)) { + if (__Basics_isDebug && queue.some((p) => p.a.__$id === procId.a.__$id)) { __Debug_crash( 12, __Debug_runtimeCrashReason("procIdAlreadyInQueue"), procId && procId.a && procId.a.__$id ); } - //*/ queue.push(procId); if (working) { return procId; @@ -141,8 +132,7 @@ const _Scheduler_getWokenValue = (procId) => { }; const _Scheduler_setWakeTask = F2((procId, newRoot) => { - /**__DEBUG/ - if (_Scheduler_readyFlgs.has(procId)) { + if (__Basics_isDebug && _Scheduler_readyFlgs.has(procId)) { __Debug_crash( 12, __Debug_runtimeCrashReason('procIdAlreadyReady'), @@ -150,7 +140,6 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { _Scheduler_readyFlgs.get(procId) ); } - //*/ _Scheduler_readyFlgs.set(procId, newRoot); return _Utils_Tuple0; }); diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index c25a763a..6d79dd42 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -5,6 +5,7 @@ import Basics exposing (LT, EQ, GT) import Dict exposing (toList) import Elm.Kernel.Debug exposing (crash) import Elm.Kernel.List exposing (Cons, Nil) +import Elm.Kernel.Basics exposing (isDebug) import Set exposing (toList) import List exposing (append) @@ -41,23 +42,20 @@ function _Utils_eqHelp(x, y, depth, stack) { return true; } - /**__DEBUG/ - if (x.$ === "Set_elm_builtin") { - x = __Set_toList(x); - y = __Set_toList(y); - } - if (x.$ === "RBNode_elm_builtin" || x.$ === "RBEmpty_elm_builtin") { - x = __Dict_toList(x); - y = __Dict_toList(y); - } - //*/ - - /**__PROD/ - if (x.$ < 0) { - x = __Dict_toList(x); - y = __Dict_toList(y); + if (__Basics_isDebug) { + if (x.$ === "Set_elm_builtin") { + x = __Set_toList(x); + y = __Set_toList(y); + } else if (x.$ === "RBNode_elm_builtin" || x.$ === "RBEmpty_elm_builtin") { + x = __Dict_toList(x); + y = __Dict_toList(y); + } + } else { + if (x.$ < 0) { + x = __Dict_toList(x); + y = __Dict_toList(y); + } } - //*/ /* The compiler ensures that the elm types of x and y are the same. * Therefore, x and y must have the same keys. @@ -88,22 +86,15 @@ function _Utils_cmp(x, y, ord) { } // Handle characters in debug mode. - /**__DEBUG/ - if (x instanceof String) { - var a = x.valueOf(); - var b = y.valueOf(); + if (__Basics_isDebug && x instanceof String) { + const a = x.valueOf(); + const b = y.valueOf(); return a === b ? 0 : a < b ? -1 : 1; } - //*/ // Handle tuples. - /**__PROD/ - if (typeof x.$ === 'undefined') - //*/ - /**__DEBUG/ - if (x.$[0] === '#') - //*/ - { + const isTuple = __Basics_isDebug ? x.$[0] === '#' : typeof x.$ === 'undefined'; + if (isTuple) { const ordA = _Utils_cmp(x.a, y.a); if (ordA !== 0) { return ordA; From 973b4855337ffc338981abbbf613401e66741d59 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 21:55:32 +0100 Subject: [PATCH 133/170] fix incorrect use of external kernel function --- src/Elm/Kernel/Utils.js | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index 6d79dd42..39d5cd5b 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -4,7 +4,7 @@ import Array exposing (toList) import Basics exposing (LT, EQ, GT) import Dict exposing (toList) import Elm.Kernel.Debug exposing (crash) -import Elm.Kernel.List exposing (Cons, Nil) +import Elm.Kernel.List exposing (Cons, Nil, nilKey) import Elm.Kernel.Basics exposing (isDebug) import Set exposing (toList) import List exposing (append) @@ -111,13 +111,13 @@ function _Utils_cmp(x, y, ord) { // but the first list is longer than the first list is greater (and visa // versa). while (true) { - if (x.$ === _List_nilKey) { - if (y.$ === _List_nilKey) { + if (x.$ === __List_nilKey) { + if (y.$ === __List_nilKey) { return 0; } else { return -1; } - } else if (y.$ === _List_nilKey) { + } else if (y.$ === __List_nilKey) { return 1; } const ord = _Utils_cmp(x.a, y.a); From 62902b7cb5576b78d95febfc665d3ad5ce272714 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 22:05:41 +0100 Subject: [PATCH 134/170] prettier check-kernel-imports --- tests/check-kernel-imports.js | 79 +++++++++++++++++++---------------- 1 file changed, 44 insertions(+), 35 deletions(-) diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js index 88432b5e..7966ccef 100755 --- a/tests/check-kernel-imports.js +++ b/tests/check-kernel-imports.js @@ -1,8 +1,8 @@ #! /usr/bin/env node -const path = require('path'); -const fs = require('fs'); -const readline = require('readline'); +const path = require("path"); +const fs = require("fs"); +const readline = require("readline"); async function* getFiles(dir) { const dirents = await fs.promises.readdir(dir, { withFileTypes: true }); @@ -27,22 +27,24 @@ class CallLocation { async function* withLineNumbers(rl) { let i = 1; for await (const line of rl) { - yield { line, number: i } + yield { line, number: i }; i += 1; } } async function processElmFile(file, kernelCalls) { - const lines = withLineNumbers(readline.createInterface({ - input: fs.createReadStream(file) - })); + const lines = withLineNumbers( + readline.createInterface({ + input: fs.createReadStream(file), + }) + ); const kernelImports = new Map(); const errors = []; const warnings = []; - for await (const {number, line} of lines) { + for await (const { number, line } of lines) { const importMatch = line.match(/^import\s+(Elm\.Kernel\.\w+)/u); if (importMatch !== null) { kernelImports.set(importMatch[1], false); @@ -78,24 +80,27 @@ async function processElmFile(file, kernelCalls) { } async function processJsFile(file, kernelDefinitions) { - const lines = withLineNumbers(readline.createInterface({ - input: fs.createReadStream(file) - })); + const lines = withLineNumbers( + readline.createInterface({ + input: fs.createReadStream(file), + }) + ); - const moduleName = path.basename(file, '.js'); + const moduleName = path.basename(file, ".js"); const imports = new Map(); const errors = []; const warnings = []; - for await (const {number, line} of lines) { - - const importMatch = line.match(/import\s+(?:(?:\w|\.)+\.)?(\w+)\s+(?:as (\w+)\s+)?exposing\s+\((\w+(?:,\s+\w+)*)\)/); + for await (const { number, line } of lines) { + const importMatch = line.match( + /import\s+(?:(?:\w|\.)+\.)?(\w+)\s+(?:as (\w+)\s+)?exposing\s+\((\w+(?:,\s+\w+)*)\)/ + ); if (importMatch !== null) { // use alias if it is there, otherwise use last part of import. let moduleAlias = importMatch[2] !== undefined ? importMatch[2] : importMatch[1]; - for (const defName of importMatch[3].split(',').map(s => s.trim())) { + for (const defName of importMatch[3].split(",").map((s) => s.trim())) { imports.set(`__${moduleAlias}_${defName}`, false); } continue; @@ -107,13 +112,15 @@ async function processJsFile(file, kernelDefinitions) { } if (defMatch !== null) { if (defMatch[2] !== moduleName) { - errors.push(`Kernel definition ${defMatch[1]} at ${file}:${number} should match _${moduleName}_*`); + errors.push( + `Kernel definition ${defMatch[1]} at ${file}:${number} should match _${moduleName}_*` + ); } let defName = defMatch[3]; - if (defName.endsWith('__DEBUG')) { - defName = defName.substr(0, defName.length - '__DEBUG'.length); - } else if (defName.endsWith('__PROD')) { - defName = defName.substr(0, defName.length - '__PROD'.length); + if (defName.endsWith("__DEBUG")) { + defName = defName.substr(0, defName.length - "__DEBUG".length); + } else if (defName.endsWith("__PROD")) { + defName = defName.substr(0, defName.length - "__PROD".length); } // todo(Harry): check __DEBUG and __PROD match. @@ -135,7 +142,6 @@ async function processJsFile(file, kernelDefinitions) { index += kernelCallMatch.index + kernelCallMatch[0].length; } } - } for (const [kernelModule, used] of imports.entries()) { @@ -144,17 +150,18 @@ async function processJsFile(file, kernelDefinitions) { } } - return {errors, warnings}; + return { errors, warnings }; } async function main() { if (process.argv.length !== 3) { - console.error('check-kernel-imports: error! path to source directories required'); + console.error("check-kernel-imports: error! path to source directories required"); process.exit(1); } - if (process.argv.includes('-h') || process.argv.includes('--help')) { - console.log(` + if (process.argv.includes("-h") || process.argv.includes("--help")) { + console.log( + ` Usage: check-kernel-imports SOURCE_DIRECTORY @@ -167,13 +174,13 @@ Additionally, warnings will be issued for unused imports in javascript files. Options: -h, --help display this help and exit - `.trim()) + `.trim() + ); process.exit(0); } const sourceDir = process.argv[2]; - // keys: kernel definition full elm path const kernelDefinitions = new Set(); // keys: kernel call, values: array of CallLocations @@ -184,11 +191,11 @@ Options: for await (const f of getFiles(sourceDir)) { const extname = path.extname(f); - if (extname === '.elm') { + if (extname === ".elm") { const { errors, warnings } = await processElmFile(f, kernelCalls); allErrors.push(...errors); allWarnings.push(...warnings); - } else if (extname === '.js') { + } else if (extname === ".js") { const { errors, warnings } = await processJsFile(f, kernelDefinitions); allErrors.push(...errors); allWarnings.push(...warnings); @@ -197,15 +204,17 @@ Options: for (const [call, locations] of kernelCalls.entries()) { if (!kernelDefinitions.has(call)) { for (const location of locations) { - allErrors.push(`Kernel call ${call} at ${location.path}:${location.line} missing definition`); + allErrors.push( + `Kernel call ${call} at ${location.path}:${location.line} missing definition` + ); } } } console.error(`${allWarnings.length} warnings`); - console.error(allWarnings.join('\n')); - console.error(''); - console.error(`${allErrors.length} errors`) - console.error(allErrors.join('\n')); + console.error(allWarnings.join("\n")); + console.error(""); + console.error(`${allErrors.length} errors`); + console.error(allErrors.join("\n")); process.exitCode = allErrors.length === 0 ? 0 : 1; } From 7c5a39b3beb681b7ea5242ed4a4f98a0c1ce6058 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 22:08:49 +0100 Subject: [PATCH 135/170] fix other kernel function calls with only one _ --- src/Elm/Kernel/Channel.js | 4 ++-- src/Elm/Kernel/Scheduler.js | 3 ++- tests/check-kernel-imports.js | 20 +++++++++++++++----- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Elm/Kernel/Channel.js b/src/Elm/Kernel/Channel.js index fea0aa78..e01fffab 100644 --- a/src/Elm/Kernel/Channel.js +++ b/src/Elm/Kernel/Channel.js @@ -3,7 +3,7 @@ import Maybe exposing (Just, Nothing) import Elm.Kernel.Basics exposing (isDebug) import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) -import Elm.Kernel.Utils exposing (Tuple2) +import Elm.Kernel.Utils exposing (Tuple0, Tuple2) */ const _Channel_channels = new WeakMap(); @@ -80,7 +80,7 @@ const _Channel_rawSendImpl = F2((channelId, msg) => { channel.wakers.delete(nextWaker); nextWaker(msg); } - return _Utils_Tuple0; + return __Utils_Tuple0; }); const _Channel_rawSend = F2((sender, msg) => { diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index cec81048..b01fe800 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -4,6 +4,7 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) import Maybe exposing (Just, Nothing) import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Basics exposing (isDebug) +import Elm.Kernel.Utils exposing (Tuple0) */ // COMPATIBILITY @@ -141,5 +142,5 @@ const _Scheduler_setWakeTask = F2((procId, newRoot) => { ); } _Scheduler_readyFlgs.set(procId, newRoot); - return _Utils_Tuple0; + return __Utils_Tuple0; }); diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js index 7966ccef..fe4dce8d 100755 --- a/tests/check-kernel-imports.js +++ b/tests/check-kernel-imports.js @@ -129,15 +129,25 @@ async function processJsFile(file, kernelDefinitions) { let index = 0; while (true) { - const kernelCallMatch = line.substr(index).match(/__\w+_\w+/u); + const kernelCallMatch = line.substr(index).match(/_?_\w+_\w+/u); if (kernelCallMatch === null) { break; } else { const kernelCall = kernelCallMatch[0]; - if (imports.has(kernelCall)) { - imports.set(kernelCall, true); - } else { - errors.push(`Kernel call ${kernelCall} at ${file}:${number} missing import`); + if (kernelCall.startsWith("__")) { + // External kernel call + if (imports.has(kernelCall)) { + imports.set(kernelCall, true); + } else { + errors.push(`Kernel call ${kernelCall} at ${file}:${number} missing import`); + } + } else if ( + kernelCall[1] === kernelCall[1].toUpperCase() && + !kernelCall.startsWith(`_${moduleName}`) + ) { + errors.push( + `Non-local kernel call ${kernelCall} at ${file}:${number} must start with a double underscore` + ); } index += kernelCallMatch.index + kernelCallMatch[0].length; } From a08c5970e0e2e66ceffc1361524ead93620a1f2c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 22:22:44 +0100 Subject: [PATCH 136/170] add array equality test --- tests/tests/Test/Array.elm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/tests/Test/Array.elm b/tests/tests/Test/Array.elm index 3ce7e19e..af8c6735 100644 --- a/tests/tests/Test/Array.elm +++ b/tests/tests/Test/Array.elm @@ -20,6 +20,7 @@ tests = , transformTests , sliceTests , runtimeCrashTests + , equalityTests ] @@ -305,3 +306,20 @@ runtimeCrashTests = in Expect.equal res res ] + +equalityTests : Test +equalityTests = + describe "Equality of arrays" + [ fuzz (Fuzz.list Fuzz.int) "int" <| + \l -> + Array.fromList l + |> Expect.equal (Array.fromList l) + , fuzz (Fuzz.list Fuzz.string) "string" <| + \l -> + Array.fromList l + |> Expect.equal (Array.fromList l) + , fuzz (Fuzz.list Fuzz.float) "float" <| + \l -> + Array.fromList l + |> Expect.equal (Array.fromList l) + ] From 8e474a406e3bcc2c5aa73600936ac63bdf78376a Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 22:23:38 +0100 Subject: [PATCH 137/170] remove unused imports --- src/Elm/Kernel/Utils.js | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index 39d5cd5b..fba2702f 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -1,10 +1,8 @@ /* -import Array exposing (toList) -import Basics exposing (LT, EQ, GT) import Dict exposing (toList) import Elm.Kernel.Debug exposing (crash) -import Elm.Kernel.List exposing (Cons, Nil, nilKey) +import Elm.Kernel.List exposing (nilKey) import Elm.Kernel.Basics exposing (isDebug) import Set exposing (toList) import List exposing (append) From 6bed0591f4612009c1ad8685e9cb8d05f47c3fa2 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 23:31:52 +0100 Subject: [PATCH 138/170] remove module Platform.Effects --- src/Elm/Kernel/Platform.js | 10 ++++++---- src/Platform.elm | 2 +- src/Platform/Effects.elm | 19 ------------------- src/Platform/Scheduler.elm | 7 ++++++- src/Task.elm | 13 +++++++++++-- 5 files changed, 24 insertions(+), 27 deletions(-) delete mode 100644 src/Platform/Effects.elm diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index ac39cbf6..3dfeadf9 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -7,13 +7,12 @@ import Elm.Kernel.Utils exposing (Tuple0, Tuple2) import Elm.Kernel.Channel exposing (rawUnbounded, rawSend) import Elm.Kernel.Basics exposing (isDebug) import Result exposing (isOk) -import Maybe exposing (Nothing) +import Maybe exposing (Nothing, map) import Platform exposing (Task, ProcessId, initializeHelperFunctions) -import Platform.Effects as Effects exposing (mapCommand) -import Platform.Scheduler as Scheduler exposing (execImpure) import Platform.Raw.Scheduler as RawScheduler exposing (rawSpawn) import Platform.Raw.Task as RawTask exposing (execImpure, andThen) import Platform.Raw.Channel as RawChannel exposing (recv) +import Platform.Scheduler as Scheduler exposing (execImpure, map) */ @@ -330,7 +329,7 @@ const _Platform_effectManagerNameToString = (name) => name; const _Platform_getCmdMapper = (home) => { if (home === "000PlatformEffect") { - return __Effects_mapCommand; + return (tagger) => __Scheduler_map(__Maybe_map(tagger)); } return _Platform_effectManagers[home].__cmdMapper; }; @@ -346,6 +345,9 @@ const _Platform_wrapTask = (task) => __Platform_Task(task); const _Platform_wrapProcessId = (processId) => __Platform_ProcessId(processId); +// command : Platform.Task Never (Maybe msg) -> Cmd msg +const _Platform_command = _Platform_leaf("000PlatformEffect") + // EXPORT ELM MODULES // // Have DEBUG and PROD versions so that we can (1) give nicer errors in diff --git a/src/Platform.elm b/src/Platform.elm index 2e650f55..df7ddaa5 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -212,7 +212,7 @@ The channel who's sender we return is a runtime specific channel, the thunk returned by dispatchEffects will use the sender to notify this function that we have command and/or subscriptions to process. -Each command is a `Platform.Task Never (Maybe msg)`. If the Task resolves with +Each command is a `Platform.Task Never (Maybe msg)`. If the Task resolves with `Just something` we must send that `something` to the app. Each sub is a tuple `( IncomingPortId, HiddenConvertedSubType -> msg )` we can diff --git a/src/Platform/Effects.elm b/src/Platform/Effects.elm deleted file mode 100644 index ae4d76a6..00000000 --- a/src/Platform/Effects.elm +++ /dev/null @@ -1,19 +0,0 @@ -module Platform.Effects exposing (command) - -import Basics exposing (..) -import Debug -import Elm.Kernel.Platform -import Maybe exposing (Maybe(..)) -import Platform -import Platform.Cmd as Cmd exposing (Cmd) -import Platform.Scheduler as Scheduler - - -command : Platform.Task Never (Maybe msg) -> Cmd msg -command function = - Elm.Kernel.Platform.leaf "000PlatformEffect" function - - -mapCommand : (a -> b) -> Platform.Task Never (Maybe a) -> Platform.Task Never (Maybe b) -mapCommand tagger task = - Scheduler.andThen (Maybe.map tagger >> Scheduler.succeed) task diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index bce08a91..0c457ea9 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, onError, rawSpawn, sleep, spawn, succeed, unwrapTask, wrapTask) +module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, map, onError, rawSpawn, sleep, spawn, succeed, unwrapTask, wrapTask) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. @@ -112,6 +112,11 @@ andThen func = ) +map : (ok1 -> ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 +map func = + andThen (func >> succeed) + + onError : (err1 -> Platform.Task err2 ok) -> Platform.Task err1 ok -> Platform.Task err2 ok onError func = wrapTaskFn diff --git a/src/Task.elm b/src/Task.elm index 849ed9c5..13244b3c 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -31,11 +31,11 @@ HTTP requests or writing to a database. -} import Basics exposing ((<<), (|>), Never, never) +import Elm.Kernel.Platform import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform import Platform.Cmd exposing (Cmd) -import Platform.Effects import Platform.Scheduler as Scheduler import Result exposing (Result(..)) @@ -379,4 +379,13 @@ attempt resultToMessage task = performHelp : Task Never msg -> Cmd msg performHelp task = - Platform.Effects.command (map Just task) + command (map Just task) + + + +-- kernel -- + + +command : Platform.Task Never (Maybe msg) -> Cmd msg +command function = + Elm.Kernel.Platform.command From 936ec68c09a3399ee69934d52ad8054f52ebcf01 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 23:32:41 +0100 Subject: [PATCH 139/170] prettier --- src/Elm/Kernel/Platform.js | 36 ++++++++++++++++++------------------ src/Elm/Kernel/Scheduler.js | 22 +++++++++++----------- src/Elm/Kernel/Utils.js | 2 +- 3 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 3dfeadf9..deeb4b3c 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -33,11 +33,11 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { const flagsResult = A2(__Json_run, flagDecoder, __Json_wrap(args ? args["flags"] : undefined)); if (!__Result_isOk(flagsResult)) { - if (__Basics_isDebug) { - __Debug_crash(2, __Json_errorToString(result.a)); - } else { - __Debug_crash(2); - } + if (__Basics_isDebug) { + __Debug_crash(2, __Json_errorToString(result.a)); + } else { + __Debug_crash(2); + } } const selfSenders = new Map(); @@ -196,12 +196,12 @@ const _Platform_leaf = (home) => (value) => { __List_Nil ); if (__Basics_isDebug) { - return { - $: 'Data', - a: list, - }; - } - return list; + return { + $: "Data", + a: list, + }; + } + return list; }; // PORTS @@ -289,9 +289,9 @@ const _Platform_createSubProcess = (_) => { const msgHandler = (msg) => { return __RawTask_execImpure((_) => { const sendToApps = _Platform_subscriptionMap.get(key); - if (__Basics_isDebug && sendToApps === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); - } + if (__Basics_isDebug && sendToApps === undefined) { + __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); + } for (const sendToApp of sendToApps) { sendToApp(msg); } @@ -317,9 +317,9 @@ const _Platform_resetSubscriptions = (newSubs) => const key = tuple.a; const sendToApp = tuple.b; const sendToApps = _Platform_subscriptionMap.get(key); - if (__Basics_isDebug && sendToApps === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('subscriptionProcessMissing'), key && key.id); - } + if (__Basics_isDebug && sendToApps === undefined) { + __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); + } sendToApps.push(sendToApp); } return __Utils_Tuple0; @@ -346,7 +346,7 @@ const _Platform_wrapTask = (task) => __Platform_Task(task); const _Platform_wrapProcessId = (processId) => __Platform_ProcessId(processId); // command : Platform.Task Never (Maybe msg) -> Cmd msg -const _Platform_command = _Platform_leaf("000PlatformEffect") +const _Platform_command = _Platform_leaf("000PlatformEffect"); // EXPORT ELM MODULES // diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index b01fe800..bc7fa7e5 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -45,9 +45,9 @@ function _Scheduler_getGuid() { function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); - if (__Basics_isDebug && procState === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason('procIdNotRegistered'), id && id.a && id.a.__$id); - } + if (__Basics_isDebug && procState === undefined) { + __Debug_crash(12, __Debug_runtimeCrashReason("procIdNotRegistered"), id && id.a && id.a.__$id); + } return procState; } @@ -133,14 +133,14 @@ const _Scheduler_getWokenValue = (procId) => { }; const _Scheduler_setWakeTask = F2((procId, newRoot) => { - if (__Basics_isDebug && _Scheduler_readyFlgs.has(procId)) { - __Debug_crash( - 12, - __Debug_runtimeCrashReason('procIdAlreadyReady'), - procId && procId.a && procId.a.__$id, - _Scheduler_readyFlgs.get(procId) - ); - } + if (__Basics_isDebug && _Scheduler_readyFlgs.has(procId)) { + __Debug_crash( + 12, + __Debug_runtimeCrashReason("procIdAlreadyReady"), + procId && procId.a && procId.a.__$id, + _Scheduler_readyFlgs.get(procId) + ); + } _Scheduler_readyFlgs.set(procId, newRoot); return __Utils_Tuple0; }); diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index fba2702f..31beb41a 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -91,7 +91,7 @@ function _Utils_cmp(x, y, ord) { } // Handle tuples. - const isTuple = __Basics_isDebug ? x.$[0] === '#' : typeof x.$ === 'undefined'; + const isTuple = __Basics_isDebug ? x.$[0] === "#" : typeof x.$ === "undefined"; if (isTuple) { const ordA = _Utils_cmp(x.a, y.a); if (ordA !== 0) { From ed422d485023120f54575e6c52ecf701951f94c1 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 23:33:12 +0100 Subject: [PATCH 140/170] tidy tuple check --- src/Elm/Kernel/Utils.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elm/Kernel/Utils.js b/src/Elm/Kernel/Utils.js index 31beb41a..0a14d52e 100644 --- a/src/Elm/Kernel/Utils.js +++ b/src/Elm/Kernel/Utils.js @@ -91,7 +91,7 @@ function _Utils_cmp(x, y, ord) { } // Handle tuples. - const isTuple = __Basics_isDebug ? x.$[0] === "#" : typeof x.$ === "undefined"; + const isTuple = __Basics_isDebug ? x.$[0] === "#" : x.$ === undefined; if (isTuple) { const ordA = _Utils_cmp(x.a, y.a); if (ordA !== 0) { From fa10586c00d6aa594c48590c5097b35405507f45 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Tue, 14 Apr 2020 23:48:55 +0100 Subject: [PATCH 141/170] modernise js in Debug.js --- src/Elm/Kernel/Char.js | 2 +- src/Elm/Kernel/Debug.js | 90 +++++++++++++++++++---------------------- src/Platform.elm | 2 +- 3 files changed, 43 insertions(+), 51 deletions(-) diff --git a/src/Elm/Kernel/Char.js b/src/Elm/Kernel/Char.js index dd1e6a11..2af0be9f 100644 --- a/src/Elm/Kernel/Char.js +++ b/src/Elm/Kernel/Char.js @@ -5,7 +5,7 @@ import Elm.Kernel.Utils exposing (chr) */ function _Char_toCode(char) { - var code = char.charCodeAt(0); + const code = char.charCodeAt(0); if (0xd800 <= code && code <= 0xdbff) { return (code - 0xd800) * 0x400 + char.charCodeAt(1) - 0xdc00 + 0x10000; } diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 1b2311b5..21765b28 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -8,11 +8,11 @@ import Set exposing (toList) // LOG -var _Debug_log__PROD = F2(function (tag, value) { +const _Debug_log__PROD = F2(function (tag, value) { return value; }); -var _Debug_log__DEBUG = F2(function (tag, value) { +const _Debug_log__DEBUG = F2(function (tag, value) { console.log(tag + ": " + _Debug_toString(value)); return value; }); @@ -63,17 +63,17 @@ function _Debug_toAnsiString(ansi, value) { } if (typeof value === "object" && "$" in value) { - var tag = value.$; + const tag = value.$; if (typeof tag === "number") { return _Debug_internalColor(ansi, ""); } if (tag[0] === "#") { - var output = []; - for (var k in value) { + const output = []; + for (const [k, v] of Object.entries(value)) { if (k === "$") continue; - output.push(_Debug_toAnsiString(ansi, value[k])); + output.push(_Debug_toAnsiString(ansi, v)); } return "(" + output.join(",") + ")"; } @@ -106,30 +106,26 @@ function _Debug_toAnsiString(ansi, value) { } if (tag === "Cons_elm_builtin" || tag === "Nil_elm_builtin") { - var output = "["; - - value.b && ((output += _Debug_toAnsiString(ansi, value.a)), (value = value.b)); - - for ( - ; - value.b; - value = value.b // WHILE_CONS - ) { - output += "," + _Debug_toAnsiString(ansi, value.a); - } - return output + "]"; + return ( + "[" + + __List_toArray(value) + .map((v) => _Debug_toAnsiString(ansi, v)) + .join(",") + + "]" + ); } - var output = ""; - for (var i in value) { - if (i === "$") continue; - var str = _Debug_toAnsiString(ansi, value[i]); - var c0 = str[0]; - var parenless = + const parts = Object.keys(value).map(([k, v]) => { + if (k === "$") { + return _Debug_ctorColor(ansi, v); + } + const str = _Debug_toAnsiString(ansi, v); + const c0 = str[0]; + const parenless = c0 === "{" || c0 === "(" || c0 === "[" || c0 === "<" || c0 === '"' || str.indexOf(" ") < 0; - output += " " + (parenless ? str : "(" + str + ")"); - } - return _Debug_ctorColor(ansi, tag) + output; + return parenless ? str : "(" + str + ")"; + }); + return parts.join(" "); } if (typeof DataView === "function" && value instanceof DataView) { @@ -141,22 +137,18 @@ function _Debug_toAnsiString(ansi, value) { } if (typeof value === "object") { - var output = []; - for (var key in value) { - var field = key[0] === "_" ? key.slice(1) : key; - output.push(_Debug_fadeColor(ansi, field) + " = " + _Debug_toAnsiString(ansi, value[key])); - } - if (output.length === 0) { - return "{}"; - } - return "{ " + output.join(", ") + " }"; + const keyValuePairs = Object.keys(value).map(([k, v]) => { + const field = k[0] === "_" ? key.slice(1) : k; + return _Debug_fadeColor(ansi, field) + " = " + _Debug_toAnsiString(ansi, k); + }); + return "{ " + keyValuePairs.join(", ") + " }"; } return _Debug_internalColor(ansi, ""); } function _Debug_addSlashes(str, isChar) { - var s = str + const s = str .replace(/\\/g, "\\\\") .replace(/\n/g, "\\n") .replace(/\t/g, "\\t") @@ -281,22 +273,22 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) { ); case 2: { - var jsonErrorString = fact1; + const jsonErrorString = fact1; throw new Error( "Problem with the flags given to your Elm program on initialization.\n\n" + jsonErrorString ); } case 3: { - var portName = fact1; + const portName = fact1; throw new Error( "There can only be one port named `" + portName + "`, but your program has multiple." ); } case 4: { - var portName = fact1; - var problem = fact2; + const portName = fact1; + const problem = fact2; throw new Error( "Trying to send an unexpected type of value through port `" + portName + "`:\n" + problem ); @@ -308,7 +300,7 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) { ); case 6: { - var moduleName = fact1; + const moduleName = fact1; throw new Error( "Your page is loading multiple Elm scripts with a module named " + moduleName + @@ -317,19 +309,19 @@ function _Debug_crash__DEBUG(identifier, fact1, fact2, fact3, fact4) { } case 8: { - var moduleName = fact1; - var region = fact2; - var message = fact3; + const moduleName = fact1; + const region = fact2; + const message = fact3; throw new Error( "TODO in module `" + moduleName + "` " + _Debug_regionToString(region) + "\n\n" + message ); } case 9: { - var moduleName = fact1; - var region = fact2; - var value = fact3; - var message = fact4; + const moduleName = fact1; + const region = fact2; + const value = fact3; + const message = fact4; throw new Error( "TODO in module `" + moduleName + diff --git a/src/Platform.elm b/src/Platform.elm index df7ddaa5..ebb5f255 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -121,7 +121,7 @@ all the complex logic in Elm. Initializing a headless program from JavaScript looks like this: ```javascript -var app = Elm.MyThing.init(); +const app = Elm.MyThing.init(); ``` If you _do_ want to control the user interface in Elm, the [`Browser`][browser] From 07b91b9a0b1ce5062669737ede3b8045879dfe72 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 15 Apr 2020 13:25:27 +0100 Subject: [PATCH 142/170] fix missing import --- src/Elm/Kernel/Debug.js | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 21765b28..aae22b03 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -3,6 +3,7 @@ import Array exposing (toList) import Dict exposing (toList) import Set exposing (toList) +import Elm.Kernel.List exposing (toArray) */ From b9fee3c824f10e4c67a05f7a9042d7d72c47d964 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 15 Apr 2020 15:12:01 +0100 Subject: [PATCH 143/170] fix task commands --- src/Task.elm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Task.elm b/src/Task.elm index 13244b3c..4c5fc3dc 100644 --- a/src/Task.elm +++ b/src/Task.elm @@ -387,5 +387,5 @@ performHelp task = command : Platform.Task Never (Maybe msg) -> Cmd msg -command function = +command = Elm.Kernel.Platform.command From 7c1fd505bfcca9620af1aee3c55677e8a3bbea5e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 15 Apr 2020 15:18:36 +0100 Subject: [PATCH 144/170] fix debug to string printing --- src/Elm/Kernel/Debug.js | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index aae22b03..02e9dec8 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -116,7 +116,7 @@ function _Debug_toAnsiString(ansi, value) { ); } - const parts = Object.keys(value).map(([k, v]) => { + const parts = Object.entries(value).map(([k, v]) => { if (k === "$") { return _Debug_ctorColor(ansi, v); } @@ -138,9 +138,9 @@ function _Debug_toAnsiString(ansi, value) { } if (typeof value === "object") { - const keyValuePairs = Object.keys(value).map(([k, v]) => { - const field = k[0] === "_" ? key.slice(1) : k; - return _Debug_fadeColor(ansi, field) + " = " + _Debug_toAnsiString(ansi, k); + const keyValuePairs = Object.entries(value).map(([k, v]) => { + const field = k[0] === "_" ? k.slice(1) : k; + return _Debug_fadeColor(ansi, field) + " = " + _Debug_toAnsiString(ansi, v); }); return "{ " + keyValuePairs.join(", ") + " }"; } From 27334c6f2ea7eae87543e68f034dba078dbbc953 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 15 Apr 2020 15:19:40 +0100 Subject: [PATCH 145/170] remove messy wake logic from scheduler --- src/Elm/Kernel/Scheduler.js | 17 ++++++++------- src/Platform/Raw/Scheduler.elm | 40 +++++----------------------------- 2 files changed, 15 insertions(+), 42 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index bc7fa7e5..4160cca0 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -67,7 +67,7 @@ const _Scheduler_enqueueWithStepper = (stepper) => { let working = false; const queue = []; - const stepProccessWithId = (newProcId) => { + const stepProccessWithId = (newProcId, newRootTask) => { const procState = _Scheduler_processes.get(newProcId); if (__Basics_isDebug && procState === undefined) { __Debug_crash( @@ -76,7 +76,7 @@ const _Scheduler_enqueueWithStepper = (stepper) => { newProcId && newProcId.a && newProcId.a.__$id ); } - const updatedState = A2(stepper, newProcId, procState); + const updatedState = A2(stepper, newProcId, newRootTask); if (__Basics_isDebug && procState !== _Scheduler_processes.get(newProcId)) { __Debug_crash( 12, @@ -87,26 +87,27 @@ const _Scheduler_enqueueWithStepper = (stepper) => { _Scheduler_processes.set(newProcId, updatedState); }; - return (procId) => { - if (__Basics_isDebug && queue.some((p) => p.a.__$id === procId.a.__$id)) { + return (procId) => (rootTask) => { + if (__Basics_isDebug && queue.some((p) => p[0].a.__$id === procId.a.__$id)) { __Debug_crash( 12, __Debug_runtimeCrashReason("procIdAlreadyInQueue"), procId && procId.a && procId.a.__$id ); } - queue.push(procId); + queue.push([procId, rootTask]); if (working) { return procId; } working = true; while (true) { - const newProcId = queue.shift(); - if (newProcId === undefined) { + const next = queue.shift(); + if (next === undefined) { working = false; return procId; } - stepProccessWithId(newProcId); + const [newProcId, newRootTask] = next; + stepProccessWithId(newProcId, newRootTask); } }; }; diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index 9842de95..ba96bfd7 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -37,6 +37,7 @@ rawSpawn initTask = (ProcessId { id = getGuid () }) (Ready initTask) ) + initTask {-| Create a task that spawns a processes. @@ -84,7 +85,7 @@ call, drain the run queue but stepping all processes. Returns the enqueued `Process`. -} -enqueue : ProcessId -> ProcessId +enqueue : ProcessId -> RawTask.Task state -> ProcessId enqueue = enqueueWithStepper stepper @@ -99,23 +100,8 @@ This function **must** return a process with the **same ID** as the process it is passed as an argument -} -stepper : ProcessId -> ProcessState state -> ProcessState state -stepper processId process = - case process of - Running _ -> - case getWokenValue processId of - Just root -> - createStateWithRoot processId root - - Nothing -> - process - - Ready root -> - createStateWithRoot processId root - - -createStateWithRoot : ProcessId -> RawTask.Task state -> ProcessState state -createStateWithRoot processId root = +stepper : ProcessId -> RawTask.Task state -> ProcessState state +stepper processId root = case root of RawTask.Value val -> Ready (RawTask.Value val) @@ -124,13 +110,9 @@ createStateWithRoot processId root = Running (doEffect (\newRoot -> - let - () = - setWakeTask processId newRoot - in let (ProcessId _) = - enqueue processId + enqueue processId newRoot in () ) @@ -168,16 +150,6 @@ registerNewProcess = Elm.Kernel.Scheduler.registerNewProcess -enqueueWithStepper : (ProcessId -> ProcessState state -> ProcessState state) -> ProcessId -> ProcessId +enqueueWithStepper : (ProcessId -> RawTask.Task state -> ProcessState state) -> ProcessId -> RawTask.Task state -> ProcessId enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper - - -getWokenValue : ProcessId -> Maybe (RawTask.Task state) -getWokenValue = - Elm.Kernel.Scheduler.getWokenValue - - -setWakeTask : ProcessId -> RawTask.Task state -> () -setWakeTask = - Elm.Kernel.Scheduler.setWakeTask From 3f99f1e0355f1067e897c92b788a9b04d80052c9 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 15 Apr 2020 15:35:08 +0100 Subject: [PATCH 146/170] do not register new processes --- src/Elm/Kernel/Scheduler.js | 52 +++------------------------------- src/Platform/Raw/Scheduler.elm | 19 +++++-------- 2 files changed, 11 insertions(+), 60 deletions(-) diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index 4160cca0..b2122dca 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -37,7 +37,6 @@ function _Scheduler_rawSpawn(task) { var _Scheduler_guid = 0; var _Scheduler_processes = new WeakMap(); -var _Scheduler_readyFlgs = new WeakMap(); function _Scheduler_getGuid() { return _Scheduler_guid++; @@ -45,10 +44,10 @@ function _Scheduler_getGuid() { function _Scheduler_getProcessState(id) { const procState = _Scheduler_processes.get(id); - if (__Basics_isDebug && procState === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason("procIdNotRegistered"), id && id.a && id.a.__$id); + if (procState === undefined) { + return __Maybe_Nothing; } - return procState; + return __Maybe_Just(procState); } var _Scheduler_registerNewProcess = F2((procId, procState) => { @@ -67,26 +66,6 @@ const _Scheduler_enqueueWithStepper = (stepper) => { let working = false; const queue = []; - const stepProccessWithId = (newProcId, newRootTask) => { - const procState = _Scheduler_processes.get(newProcId); - if (__Basics_isDebug && procState === undefined) { - __Debug_crash( - 12, - __Debug_runtimeCrashReason("procIdNotRegistered"), - newProcId && newProcId.a && newProcId.a.__$id - ); - } - const updatedState = A2(stepper, newProcId, newRootTask); - if (__Basics_isDebug && procState !== _Scheduler_processes.get(newProcId)) { - __Debug_crash( - 12, - __Debug_runtimeCrashReason("reentrantProcUpdate"), - newProcId && newProcId.a && newProcId.a.__$id - ); - } - _Scheduler_processes.set(newProcId, updatedState); - }; - return (procId) => (rootTask) => { if (__Basics_isDebug && queue.some((p) => p[0].a.__$id === procId.a.__$id)) { __Debug_crash( @@ -107,7 +86,7 @@ const _Scheduler_enqueueWithStepper = (stepper) => { return procId; } const [newProcId, newRootTask] = next; - stepProccessWithId(newProcId, newRootTask); + _Scheduler_processes.set(newProcId, A2(stepper, newProcId, newRootTask)); } }; }; @@ -122,26 +101,3 @@ var _Scheduler_delay = F3(function (time, value, callback) { return x; }; }); - -const _Scheduler_getWokenValue = (procId) => { - const flag = _Scheduler_readyFlgs.get(procId); - if (flag === undefined) { - return __Maybe_Nothing; - } else { - _Scheduler_readyFlgs.delete(procId); - return __Maybe_Just(flag); - } -}; - -const _Scheduler_setWakeTask = F2((procId, newRoot) => { - if (__Basics_isDebug && _Scheduler_readyFlgs.has(procId)) { - __Debug_crash( - 12, - __Debug_runtimeCrashReason("procIdAlreadyReady"), - procId && procId.a && procId.a.__$id, - _Scheduler_readyFlgs.get(procId) - ); - } - _Scheduler_readyFlgs.set(procId, newRoot); - return __Utils_Tuple0; -}); diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index ba96bfd7..466608cc 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -33,10 +33,7 @@ Will create, register and **enqueue** a new process. rawSpawn : RawTask.Task a -> ProcessId rawSpawn initTask = enqueue - (registerNewProcess - (ProcessId { id = getGuid () }) - (Ready initTask) - ) + (ProcessId { id = getGuid () }) initTask @@ -124,10 +121,13 @@ stepper processId root = rawKill : ProcessId -> () rawKill id = case getProcessState id of - Running killer -> + Just (Running killer) -> killer () - Ready _ -> + Just (Ready _) -> + () + + Nothing -> () @@ -140,16 +140,11 @@ getGuid = Elm.Kernel.Scheduler.getGuid -getProcessState : ProcessId -> ProcessState state +getProcessState : ProcessId -> Maybe (ProcessState state) getProcessState = Elm.Kernel.Scheduler.getProcessState -registerNewProcess : ProcessId -> ProcessState state -> ProcessId -registerNewProcess = - Elm.Kernel.Scheduler.registerNewProcess - - enqueueWithStepper : (ProcessId -> RawTask.Task state -> ProcessState state) -> ProcessId -> RawTask.Task state -> ProcessId enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper From 1b0eede1f0ab3c0851625eb0e8ea83b2be41b365 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Wed, 15 Apr 2020 22:03:32 +0100 Subject: [PATCH 147/170] fix incoming ports not a fix I am happy with, further iteration needed --- src/Elm/Kernel/Platform.js | 14 +++++---- src/Elm/Kernel/Scheduler.js | 1 - src/Platform.elm | 59 +++++++++++++++++++++++++++---------- 3 files changed, 51 insertions(+), 23 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index deeb4b3c..91b0c4ac 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -8,7 +8,7 @@ import Elm.Kernel.Channel exposing (rawUnbounded, rawSend) import Elm.Kernel.Basics exposing (isDebug) import Result exposing (isOk) import Maybe exposing (Nothing, map) -import Platform exposing (Task, ProcessId, initializeHelperFunctions) +import Platform exposing (Task, ProcessId, initializeHelperFunctions, ImpureFunction) import Platform.Raw.Scheduler as RawScheduler exposing (rawSpawn) import Platform.Raw.Task as RawTask exposing (execImpure, andThen) import Platform.Raw.Channel as RawChannel exposing (recv) @@ -66,7 +66,9 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { fx.__subs ); for (const [key, selfSender] of selfSenders.entries()) { - __RawScheduler_rawSpawn(A2(dispatcher, key, selfSender)); + const tuple = A2(dispatcher, key, selfSender); + tuple.a(sendToApp); + __RawScheduler_rawSpawn(tuple.b); } } }; @@ -286,8 +288,8 @@ let _Platform_subscriptionProcessIds = 0; const _Platform_createSubProcess = (_) => { const channel = __Channel_rawUnbounded(); const key = { id: _Platform_subscriptionProcessIds++ }; - const msgHandler = (msg) => { - return __RawTask_execImpure((_) => { + const msgHandler = (msg) => + __RawTask_execImpure((_) => { const sendToApps = _Platform_subscriptionMap.get(key); if (__Basics_isDebug && sendToApps === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); @@ -297,7 +299,6 @@ const _Platform_createSubProcess = (_) => { } return __Utils_Tuple0; }); - }; const onSubEffects = (_) => A2(__RawTask_andThen, onSubEffects, A2(__RawChannel_recv, msgHandler, channel.b)); @@ -309,7 +310,8 @@ const _Platform_createSubProcess = (_) => { }; const _Platform_resetSubscriptions = (newSubs) => - __RawTask_execImpure((_) => { + __Platform_ImpureFunction((_) => { + console.log(`new subs using ${__List_toArray(newSubs).join(",")}`); for (const sendToApps of _Platform_subscriptionMap.values()) { sendToApps.length = 0; } diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index b2122dca..defcceb5 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -4,7 +4,6 @@ import Platform.Scheduler as NiceScheduler exposing (succeed, binding, rawSpawn) import Maybe exposing (Just, Nothing) import Elm.Kernel.Debug exposing (crash, runtimeCrashReason) import Elm.Kernel.Basics exposing (isDebug) -import Elm.Kernel.Utils exposing (Tuple0) */ // COMPATIBILITY diff --git a/src/Platform.elm b/src/Platform.elm index ebb5f255..72b514be 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -74,7 +74,7 @@ type alias InitializeHelperFunctions model appMsg = -> Sub appMsg -> Bag.EffectManagerName -> Channel.Sender (AppMsgPayload appMsg) - -> RawTask.Task () + -> (SendToApp appMsg -> (), RawTask.Task ()) } @@ -227,7 +227,7 @@ setupEffectsChannel sendToApp2 = Channel.rawUnbounded () receiveMsg : AppMsgPayload appMsg -> RawTask.Task () - receiveMsg ( cmds, subs ) = + receiveMsg ( cmds, _ ) = let cmdTask = cmds @@ -260,19 +260,9 @@ setupEffectsChannel sendToApp2 = ) (RawTask.Value []) |> RawTask.andThen RawScheduler.batch - - -- Reset and re-register all subscriptions. - subTask = - subs - |> List.map createPlatformEffectFuncsFromSub - |> List.map - (\( id, tagger ) -> - ( id, \v -> sendToApp2 (tagger v) AsyncUpdate ) - ) - |> resetSubscriptions in cmdTask - |> RawTask.andThen (\_ -> subTask) + |> RawTask.map (\_ -> ()) dispatchTask : () -> RawTask.Task () dispatchTask () = @@ -291,7 +281,7 @@ dispatchEffects : -> Sub appMsg -> Bag.EffectManagerName -> Channel.Sender (AppMsgPayload appMsg) - -> RawTask.Task () + -> ( SendToApp appMsg -> (), RawTask.Task () ) dispatchEffects cmdBag subBag = let effectsDict = @@ -305,10 +295,31 @@ dispatchEffects cmdBag subBag = Maybe.withDefault ( [], [] ) (Dict.get (effectManagerNameToString key) effectsDict) + + updateSubs sendToAppFunc = + if effectManagerNameToString key == "000PlatformEffect" then + let + -- Reset and re-register all subscriptions. + (ImpureFunction ip) = + subList + |> createHiddenMySubList + |> List.map createPlatformEffectFuncsFromSub + |> List.map + (\( id, tagger ) -> + ( id, \v -> sendToAppFunc (tagger v) AsyncUpdate ) + ) + |> resetSubscriptions + in + ip () + + else + () in - Channel.send + ( updateSubs + , Channel.send channel ( createHiddenMyCmdList cmdList, createHiddenMySubList subList ) + ) gatherCmds : @@ -470,6 +481,18 @@ wrapTask task = Task (RawTask.map Ok task) +impureAndThen : ImpureFunction -> ImpureFunction -> ImpureFunction +impureAndThen (ImpureFunction ip1) (ImpureFunction ip2) = + ImpureFunction + (\() -> + let + () = + ip1 () + in + ip2 () + ) + + type alias SendToApp msg = msg -> UpdateMetadata -> () @@ -505,6 +528,10 @@ type alias AppMsgPayload appMsg = ( List (HiddenMyCmd appMsg), List (HiddenMySub appMsg) ) +type ImpureFunction + = ImpureFunction (() -> ()) + + type HiddenMyCmd msg = HiddenMyCmd (HiddenMyCmd msg) @@ -590,6 +617,6 @@ createPlatformEffectFuncsFromSub = Elm.Kernel.Basics.fudgeType -resetSubscriptions : List ( IncomingPortId, HiddenConvertedSubType -> () ) -> RawTask.Task () +resetSubscriptions : List ( IncomingPortId, HiddenConvertedSubType -> () ) -> ImpureFunction resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions From 1a33464001ff71a1434b4c96f0620c3aba696ac1 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 16 Apr 2020 23:31:33 +0100 Subject: [PATCH 148/170] remove support for effect managers! Big commit this one :) --- src/Elm/Kernel/Debug.js | 15 +++ src/Elm/Kernel/Platform.js | 161 ++++++++--------------------- src/Platform.elm | 205 ++++--------------------------------- src/Platform/Cmd.elm | 41 +++++--- src/Platform/Sub.elm | 29 +++--- 5 files changed, 121 insertions(+), 330 deletions(-) diff --git a/src/Elm/Kernel/Debug.js b/src/Elm/Kernel/Debug.js index 02e9dec8..f5d4a151 100644 --- a/src/Elm/Kernel/Debug.js +++ b/src/Elm/Kernel/Debug.js @@ -251,6 +251,21 @@ function _Debug_runtimeCrashReason__DEBUG(reason) { ).join(", ")}` ); }; + + case "EffectModule": + return function (fact2, fact3, fact4) { + throw new Error( + `Effect modules are not supported, if you are using elm/* libraries you will need to switch to a custom version.` + ); + }; + + case "PlatformLeaf": + return function (home, fact3, fact4) { + throw new Error( + `Trying to create a command or a subscription for event manager ${home}. +Effect modules are not supported, if you are using elm/* libraries you will need to switch to a custom version.` + ); + }; } throw new Error(`Unknown reason for runtime crash: ${fact1}!`); } diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 91b0c4ac..f5ccd021 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -20,7 +20,6 @@ import Platform.Scheduler as Scheduler exposing (execImpure, map) var _Platform_outgoingPorts = new Map(); var _Platform_incomingPorts = new Map(); -var _Platform_effectManagers = {}; var _Platform_effectsQueue = []; var _Platform_effectDispatchInProgress = false; @@ -40,7 +39,7 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { } } - const selfSenders = new Map(); + let cmdSender; const ports = {}; const dispatch = (model, cmds) => { @@ -60,16 +59,14 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { _Platform_effectDispatchInProgress = false; return; } - const dispatcher = A2( + const tuple = A3( __Platform_initializeHelperFunctions.__$dispatchEffects, fx.__cmds, - fx.__subs + fx.__subs, + cmdSender ); - for (const [key, selfSender] of selfSenders.entries()) { - const tuple = A2(dispatcher, key, selfSender); - tuple.a(sendToApp); - __RawScheduler_rawSpawn(tuple.b); - } + tuple.a(sendToApp); + __RawScheduler_rawSpawn(tuple.b); } }; @@ -84,24 +81,9 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { __RawScheduler_rawSpawn(init(__Utils_Tuple0)); } - selfSenders.set( - "000PlatformEffect", - __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp) - ); - for (const [key, effectManagerFunctions] of Object.entries(_Platform_effectManagers)) { - const managerChannel = __Channel_rawUnbounded(__Utils_Tuple0); - __RawScheduler_rawSpawn( - A5( - __Platform_initializeHelperFunctions.__$setupEffects, - sendToApp, - managerChannel.b, - effectManagerFunctions.__init, - effectManagerFunctions.__fullOnEffects, - effectManagerFunctions.__onSelfMsg - ) - ); - selfSenders.set(key, managerChannel.a); - } + cmdSender = __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp); + + for (const [key, { port }] of _Platform_outgoingPorts.entries()) { ports[key] = port; } @@ -132,56 +114,8 @@ function _Platform_registerPreload(url) { // EFFECT MANAGERS -/* Called by compiler generated js when creating event mangers. - * - * This function will **always** be call right after page load like this: - * - * _Platform_effectManagers['XXX'] = - * _Platform_createManager($init, $onEffects, $onSelfMsg, $cmdMap); - * - * or - * - * _Platform_effectManagers['XXX'] = - * _Platform_createManager($init, $onEffects, $onSelfMsg, 0, $subMap); - * - * or - * - * _Platform_effectManagers['XXX'] = - * _Platform_createManager($init, $onEffects, $onSelfMsg, $cmdMap, $subMap); - */ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { - if (typeof cmdMap !== "function") { - // Subscription only effect module - return { - __cmdMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason("cmdMap"))), - __subMapper: subMap, - __init: init, - __fullOnEffects: F4(function (router, _cmds, subs, state) { - return A3(onEffects, router, subs, state); - }), - __onSelfMsg: onSelfMsg, - }; - } else if (typeof subMap !== "function") { - // Command only effect module - return { - __cmdMapper: cmdMap, - __subMapper: F2((_1, _2) => __Debug_crash(12, __Debug_runtimeCrashReason("subMap"))), - __init: init, - __fullOnEffects: F4(function (router, cmds, _subs, state) { - return A3(onEffects, router, cmds, state); - }), - __onSelfMsg: onSelfMsg, - }; - } else { - // Command **and** subscription event manager - return { - __cmdMapper: cmdMap, - __subMapper: subMap, - __init: init, - __fullOnEffects: onEffects, - __onSelfMsg: onSelfMsg, - }; - } + __Debug_crash(12, __Debug_runtimeCrashReason("EffectModule")); } // BAGS @@ -190,26 +124,13 @@ function _Platform_createManager(init, onEffects, onSelfMsg, cmdMap, subMap) { * `command` or `subscription` function within an event manager */ const _Platform_leaf = (home) => (value) => { - const list = __List_Cons( - { - __$home: home, - __$value: value, - }, - __List_Nil - ); - if (__Basics_isDebug) { - return { - $: "Data", - a: list, - }; - } - return list; + __Debug_crash(12, __Debug_runtimeCrashReason("PlatformLeaf", home)); }; // PORTS function _Platform_checkPortName(name) { - if (_Platform_effectManagers[name]) { + if (_Platform_outgoingPorts.has(name) || _Platform_incomingPorts.has(name)) { __Debug_crash(3, name); } } @@ -243,15 +164,12 @@ function _Platform_outgoingPort(name, converter) { }, }); - return (payload) => - A2( - _Platform_leaf, - "000PlatformEffect", - __Scheduler_execImpure((_) => { - execSubscribers(payload); - return __Maybe_Nothing; - }) - ); + return (payload) => _Platform_command( + __Scheduler_execImpure((_) => { + execSubscribers(payload); + return __Maybe_Nothing; + }) + ); } function _Platform_incomingPort(name, converter) { @@ -276,7 +194,19 @@ function _Platform_incomingPort(name, converter) { }, }); - return (tagger) => A2(_Platform_leaf, "000PlatformEffect", __Utils_Tuple2(key, tagger)); + return (tagger) => { + const subData = __List_Cons( + __Utils_Tuple2(key, tagger), + __List_Nil + ); + if (__Basics_isDebug) { + return { + $: "Sub", + a: subData, + }; + } + return subData; + }; } // Functions exported to elm @@ -311,7 +241,6 @@ const _Platform_createSubProcess = (_) => { const _Platform_resetSubscriptions = (newSubs) => __Platform_ImpureFunction((_) => { - console.log(`new subs using ${__List_toArray(newSubs).join(",")}`); for (const sendToApps of _Platform_subscriptionMap.values()) { sendToApps.length = 0; } @@ -329,26 +258,24 @@ const _Platform_resetSubscriptions = (newSubs) => const _Platform_effectManagerNameToString = (name) => name; -const _Platform_getCmdMapper = (home) => { - if (home === "000PlatformEffect") { - return (tagger) => __Scheduler_map(__Maybe_map(tagger)); - } - return _Platform_effectManagers[home].__cmdMapper; -}; - -const _Platform_getSubMapper = (home) => { - if (_Platform_incomingPorts.has(home)) { - return F2((tagger, finalTagger) => (value) => tagger(finalTagger(value))); - } - return _Platform_effectManagers[home].__subMapper; -}; - const _Platform_wrapTask = (task) => __Platform_Task(task); const _Platform_wrapProcessId = (processId) => __Platform_ProcessId(processId); // command : Platform.Task Never (Maybe msg) -> Cmd msg -const _Platform_command = _Platform_leaf("000PlatformEffect"); +const _Platform_command = task => { + const cmdData = __List_Cons( + task, + __List_Nil + ); + if (__Basics_isDebug) { + return { + $: "Cmd", + a: cmdData, + }; + } + return cmdData; +}; // EXPORT ELM MODULES // diff --git a/src/Platform.elm b/src/Platform.elm index 72b514be..b763dc4d 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -62,17 +62,9 @@ type alias InitializeHelperFunctions model appMsg = { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg , setupEffectsChannel : SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) - , setupEffects : - SendToApp appMsg - -> Channel.Receiver (AppMsgPayload appMsg) - -> Task Never HiddenState - -> (Router appMsg HiddenSelfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> HiddenState -> Task Never HiddenState) - -> (Router appMsg HiddenSelfMsg -> HiddenSelfMsg -> HiddenState -> Task Never HiddenState) - -> RawTask.Task Never , dispatchEffects : Cmd appMsg -> Sub appMsg - -> Bag.EffectManagerName -> Channel.Sender (AppMsgPayload appMsg) -> (SendToApp appMsg -> (), RawTask.Task ()) } @@ -83,7 +75,6 @@ type alias InitializeHelperFunctions model appMsg = initializeHelperFunctions : InitializeHelperFunctions model msg initializeHelperFunctions = { stepperBuilder = \_ _ -> \_ _ -> () - , setupEffects = setupEffects , dispatchEffects = dispatchEffects , setupEffectsChannel = setupEffectsChannel } @@ -227,11 +218,10 @@ setupEffectsChannel sendToApp2 = Channel.rawUnbounded () receiveMsg : AppMsgPayload appMsg -> RawTask.Task () - receiveMsg ( cmds, _ ) = + receiveMsg cmds = let cmdTask = cmds - |> List.map createPlatformEffectFuncsFromCmd |> List.map (\(Task t) -> t) |> List.map (RawTask.map @@ -279,189 +269,38 @@ setupEffectsChannel sendToApp2 = dispatchEffects : Cmd appMsg -> Sub appMsg - -> Bag.EffectManagerName -> Channel.Sender (AppMsgPayload appMsg) -> ( SendToApp appMsg -> (), RawTask.Task () ) dispatchEffects cmdBag subBag = let - effectsDict = - Dict.empty - |> gatherCmds cmdBag - |> gatherSubs subBag + cmds = + unwrapCmd cmdBag + + subs = + unwrapSub subBag in - \key channel -> + \channel -> let - ( cmdList, subList ) = - Maybe.withDefault - ( [], [] ) - (Dict.get (effectManagerNameToString key) effectsDict) - updateSubs sendToAppFunc = - if effectManagerNameToString key == "000PlatformEffect" then - let - -- Reset and re-register all subscriptions. - (ImpureFunction ip) = - subList - |> createHiddenMySubList - |> List.map createPlatformEffectFuncsFromSub - |> List.map - (\( id, tagger ) -> - ( id, \v -> sendToAppFunc (tagger v) AsyncUpdate ) - ) - |> resetSubscriptions - in - ip () - - else - () + let + -- Reset and re-register all subscriptions. + (ImpureFunction ip) = + subs + |> List.map + (\( id, tagger ) -> + ( id, \v -> sendToAppFunc (tagger v) AsyncUpdate ) + ) + |> resetSubscriptions + in + ip () in ( updateSubs , Channel.send channel - ( createHiddenMyCmdList cmdList, createHiddenMySubList subList ) + cmds ) -gatherCmds : - Cmd msg - -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) - -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -gatherCmds cmdBag effectsDict = - List.foldr - (\{ home, value } dict -> gatherHelper True home value dict) - effectsDict - (unwrapCmd cmdBag) - - -gatherSubs : - Sub msg - -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) - -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -gatherSubs subBag effectsDict = - List.foldr - (\{ home, value } dict -> gatherHelper False home value dict) - effectsDict - (unwrapSub subBag) - - -gatherHelper : - Bool - -> Bag.EffectManagerName - -> Bag.LeafType msg - -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) - -> Dict String ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -gatherHelper isCmd home effectData effectsDict = - Dict.insert - (effectManagerNameToString home) - (createEffect isCmd effectData (Dict.get (effectManagerNameToString home) effectsDict)) - effectsDict - - -createEffect : - Bool - -> Bag.LeafType msg - -> Maybe ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) - -> ( List (Bag.LeafType msg), List (Bag.LeafType msg) ) -createEffect isCmd newEffect maybeEffects = - let - ( cmdList, subList ) = - case maybeEffects of - Just effects -> - effects - - Nothing -> - ( [], [] ) - in - if isCmd then - ( newEffect :: cmdList, subList ) - - else - ( cmdList, newEffect :: subList ) - - -setupEffects : - SendToApp appMsg - -> Channel.Receiver (AppMsgPayload appMsg) - -> Task Never state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> Task Never state) - -> (Router appMsg selfMsg -> selfMsg -> state -> Task Never state) - -> RawTask.Task Never -setupEffects sendToAppFunc receiver init onEffects onSelfMsg = - instantiateEffectManager - sendToAppFunc - receiver - (unwrapTask init) - (\router cmds subs state -> unwrapTask (onEffects router cmds subs state)) - (\router selfMsg state -> unwrapTask (onSelfMsg router selfMsg state)) - - -instantiateEffectManager : - SendToApp appMsg - -> Channel.Receiver (AppMsgPayload appMsg) - -> RawTask.Task state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawTask.Task state) - -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) - -> RawTask.Task Never -instantiateEffectManager sendToAppFunc appReceiver init onEffects onSelfMsg = - Channel.unbounded - |> RawTask.andThen (instantiateEffectManagerWithSelfChannel sendToAppFunc appReceiver init onEffects onSelfMsg) - - -instantiateEffectManagerWithSelfChannel : - SendToApp appMsg - -> Channel.Receiver (AppMsgPayload appMsg) - -> RawTask.Task state - -> (Router appMsg selfMsg -> List (HiddenMyCmd appMsg) -> List (HiddenMySub appMsg) -> state -> RawTask.Task state) - -> (Router appMsg selfMsg -> selfMsg -> state -> RawTask.Task state) - -> Channel.Channel (ReceivedData appMsg selfMsg) - -> RawTask.Task Never -instantiateEffectManagerWithSelfChannel sendToAppFunc appReceiver init onEffects onSelfMsg ( selfSender, selfReceiver ) = - let - receiveMsg : - state - -> ReceivedData appMsg selfMsg - -> RawTask.Task never - receiveMsg state msg = - let - task : RawTask.Task state - task = - case msg of - Self value -> - onSelfMsg (Router router) value state - - App ( cmds, subs ) -> - onEffects (Router router) cmds subs state - in - task - |> RawTask.andThen - (\val -> - RawTask.map - (\() -> val) - (RawTask.sleep 0) - ) - |> RawTask.andThen (\newState -> Channel.recv (receiveMsg newState) selfReceiver) - - initTask : RawTask.Task never - initTask = - RawTask.sleep 0 - |> RawTask.andThen (\_ -> init) - |> RawTask.andThen (\state -> Channel.recv (receiveMsg state) selfReceiver) - - forwardAppMessagesTask () = - Channel.recv - (\payload -> Channel.send selfSender (App payload)) - appReceiver - |> RawTask.andThen forwardAppMessagesTask - - router = - { sendToApp = \appMsg -> sendToAppFunc appMsg AsyncUpdate - , selfSender = \msg -> Channel.send selfSender (Self msg) - } - in - RawScheduler.spawn (forwardAppMessagesTask ()) - |> RawTask.andThen (\_ -> initTask) - - unwrapTask : Task Never a -> RawTask.Task a unwrapTask (Task task) = RawTask.map @@ -525,7 +364,7 @@ type ReceivedData appMsg selfMsg type alias AppMsgPayload appMsg = - ( List (HiddenMyCmd appMsg), List (HiddenMySub appMsg) ) + List (Task Never (Maybe appMsg)) type ImpureFunction @@ -582,12 +421,12 @@ effectManagerNameToString = Elm.Kernel.Platform.effectManagerNameToString -unwrapCmd : Cmd a -> Bag.EffectBag a +unwrapCmd : Cmd a -> List (Task Never (Maybe msg)) unwrapCmd = Elm.Kernel.Basics.unwrapTypeWrapper -unwrapSub : Sub a -> Bag.EffectBag a +unwrapSub : Sub a -> List ( IncomingPortId, HiddenConvertedSubType -> msg ) unwrapSub = Elm.Kernel.Basics.unwrapTypeWrapper diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 00490a9c..3e85a502 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -28,8 +28,12 @@ module Platform.Cmd exposing import Basics exposing (..) import Elm.Kernel.Platform +import Elm.Kernel.Basics import List import Platform.Bag as Bag +import Platform.Raw.Task as RawTask +import Maybe exposing (Maybe) +import Result exposing (Result) @@ -51,7 +55,7 @@ fit into a real application! -} type Cmd msg - = Data (Bag.EffectBag msg) + = Cmd (List (Task Never (Maybe msg))) {-| Tell the runtime that there are no commands. @@ -72,9 +76,9 @@ all do the same thing. -} batch : List (Cmd msg) -> Cmd msg batch = - List.map (\(Data cmd) -> cmd) + List.map (\(Cmd cmd) -> cmd) >> List.concat - >> Data + >> Cmd @@ -91,21 +95,28 @@ section on [structure] in the guide before reaching for this! -} map : (a -> msg) -> Cmd a -> Cmd msg -map fn (Data data) = +map fn (Cmd data) = data - |> List.map - (\{ home, value } -> - { home = home - , value = getCmdMapper home fn value - } - ) - |> Data + |> List.map (getCmdMapper fn) + |> Cmd +getCmdMapper : (a -> msg) -> Task Never (Maybe a) -> Task Never (Maybe msg) +getCmdMapper tagger task = + wrapTask (RawTask.map (Result.map (Maybe.map tagger)) (unwrapTask task)) --- Kernel function redefinitons -- +wrapTask : RawTask.Task (Result e o) -> Task e o +wrapTask = + Elm.Kernel.Platform.wrapTask -getCmdMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg -getCmdMapper = - Elm.Kernel.Platform.getCmdMapper + +unwrapTask : Task e o -> RawTask.Task (Result e o) +unwrapTask = + Elm.Kernel.Basics.unwrapTypeWrapper + + +{-| MUST mirror the definition in Platform +-} +type Task e o = + Task (RawTask.Task (Result e o)) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 55b42fbb..72cc4339 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -54,7 +54,7 @@ into a real application! -} type Sub msg - = Data (Bag.EffectBag msg) + = Sub (List ( IncomingPortId, HiddenConvertedSubType -> msg )) {-| Tell the runtime that there are no subscriptions. @@ -73,9 +73,9 @@ subscriptions. -} batch : List (Sub msg) -> Sub msg batch = - List.map (\(Data sub) -> sub) + List.map (\(Sub sub) -> sub) >> List.concat - >> Data + >> Sub @@ -92,21 +92,20 @@ section on [structure] in the guide before reaching for this! -} map : (a -> msg) -> Sub a -> Sub msg -map fn (Data data) = +map fn (Sub data) = data - |> List.map - (\{ home, value } -> - { home = home - , value = getSubMapper home fn value - } - ) - |> Data + |> List.map (getSubMapper fn) + |> Sub +type IncomingPortId + = IncomingPortId IncomingPortId --- Kernel function redefinitons -- +type HiddenConvertedSubType + = HiddenConvertedSubType HiddenConvertedSubType -getSubMapper : Bag.EffectManagerName -> (a -> msg) -> Bag.LeafType a -> Bag.LeafType msg -getSubMapper home = - Elm.Kernel.Platform.getSubMapper home + +getSubMapper : (a -> msg) -> ( IncomingPortId, HiddenConvertedSubType -> a ) -> ( IncomingPortId, HiddenConvertedSubType -> msg ) +getSubMapper fn (id, tagger) = + (id, \hcst -> fn (tagger hcst)) From 232e36699c987ba509e050730c3efb583e3dea3d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Thu, 16 Apr 2020 23:35:39 +0100 Subject: [PATCH 149/170] format --- src/Elm/Kernel/Platform.js | 40 ++++++++++++++++---------------------- src/Platform.elm | 2 +- src/Platform/Cmd.elm | 8 ++++---- src/Platform/Sub.elm | 4 ++-- 4 files changed, 24 insertions(+), 30 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index f5ccd021..d12bba11 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -83,7 +83,6 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { cmdSender = __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp); - for (const [key, { port }] of _Platform_outgoingPorts.entries()) { ports[key] = port; } @@ -164,12 +163,13 @@ function _Platform_outgoingPort(name, converter) { }, }); - return (payload) => _Platform_command( - __Scheduler_execImpure((_) => { - execSubscribers(payload); - return __Maybe_Nothing; - }) - ); + return (payload) => + _Platform_command( + __Scheduler_execImpure((_) => { + execSubscribers(payload); + return __Maybe_Nothing; + }) + ); } function _Platform_incomingPort(name, converter) { @@ -195,17 +195,14 @@ function _Platform_incomingPort(name, converter) { }); return (tagger) => { - const subData = __List_Cons( - __Utils_Tuple2(key, tagger), - __List_Nil - ); - if (__Basics_isDebug) { - return { - $: "Sub", - a: subData, - }; - } - return subData; + const subData = __List_Cons(__Utils_Tuple2(key, tagger), __List_Nil); + if (__Basics_isDebug) { + return { + $: "Sub", + a: subData, + }; + } + return subData; }; } @@ -263,11 +260,8 @@ const _Platform_wrapTask = (task) => __Platform_Task(task); const _Platform_wrapProcessId = (processId) => __Platform_ProcessId(processId); // command : Platform.Task Never (Maybe msg) -> Cmd msg -const _Platform_command = task => { - const cmdData = __List_Cons( - task, - __List_Nil - ); +const _Platform_command = (task) => { + const cmdData = __List_Cons(task, __List_Nil); if (__Basics_isDebug) { return { $: "Cmd", diff --git a/src/Platform.elm b/src/Platform.elm index b763dc4d..567c6f56 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -66,7 +66,7 @@ type alias InitializeHelperFunctions model appMsg = Cmd appMsg -> Sub appMsg -> Channel.Sender (AppMsgPayload appMsg) - -> (SendToApp appMsg -> (), RawTask.Task ()) + -> ( SendToApp appMsg -> (), RawTask.Task () ) } diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 3e85a502..8db19a0a 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -27,12 +27,12 @@ module Platform.Cmd exposing -} import Basics exposing (..) -import Elm.Kernel.Platform import Elm.Kernel.Basics +import Elm.Kernel.Platform import List +import Maybe exposing (Maybe) import Platform.Bag as Bag import Platform.Raw.Task as RawTask -import Maybe exposing (Maybe) import Result exposing (Result) @@ -118,5 +118,5 @@ unwrapTask = {-| MUST mirror the definition in Platform -} -type Task e o = - Task (RawTask.Task (Result e o)) +type Task e o + = Task (RawTask.Task (Result e o)) diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 72cc4339..4576e500 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -107,5 +107,5 @@ type HiddenConvertedSubType getSubMapper : (a -> msg) -> ( IncomingPortId, HiddenConvertedSubType -> a ) -> ( IncomingPortId, HiddenConvertedSubType -> msg ) -getSubMapper fn (id, tagger) = - (id, \hcst -> fn (tagger hcst)) +getSubMapper fn ( id, tagger ) = + ( id, \hcst -> fn (tagger hcst) ) From 0c0a46ba5256735b06d43ca80a2aa7adcc1f60fd Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 19 Apr 2020 13:34:42 +0100 Subject: [PATCH 150/170] copy in files from elm/time --- elm.json | 3 +- src/Elm/Kernel/Time.js | 52 ++++ src/Time.elm | 595 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 649 insertions(+), 1 deletion(-) create mode 100644 src/Elm/Kernel/Time.js create mode 100644 src/Time.elm diff --git a/elm.json b/elm.json index 1af06749..42c75ae8 100644 --- a/elm.json +++ b/elm.json @@ -10,7 +10,8 @@ "String", "Char", "Bitwise", - "Tuple" + "Tuple", + "Time" ], "Collections": [ "List", diff --git a/src/Elm/Kernel/Time.js b/src/Elm/Kernel/Time.js new file mode 100644 index 00000000..9ee3056f --- /dev/null +++ b/src/Elm/Kernel/Time.js @@ -0,0 +1,52 @@ +/* + +import Time exposing (customZone, Name, Offset) +import Elm.Kernel.List exposing (Nil) +import Elm.Kernel.Scheduler exposing (binding, succeed) + +*/ + + +function _Time_now(millisToPosix) +{ + return __Scheduler_binding(function(callback) + { + callback(__Scheduler_succeed(millisToPosix(Date.now()))); + }); +} + +var _Time_setInterval = F2(function(interval, task) +{ + return __Scheduler_binding(function(callback) + { + var id = setInterval(function() { _Scheduler_rawSpawn(task); }, interval); + return function() { clearInterval(id); }; + }); +}); + +function _Time_here() +{ + return __Scheduler_binding(function(callback) + { + callback(__Scheduler_succeed( + A2(__Time_customZone, -(new Date().getTimezoneOffset()), __List_Nil) + )); + }); +} + + +function _Time_getZoneName() +{ + return __Scheduler_binding(function(callback) + { + try + { + var name = __Time_Name(Intl.DateTimeFormat().resolvedOptions().timeZone); + } + catch (e) + { + var name = __Time_Offset(new Date().getTimezoneOffset()); + } + callback(__Scheduler_succeed(name)); + }); +} diff --git a/src/Time.elm b/src/Time.elm new file mode 100644 index 00000000..12db3139 --- /dev/null +++ b/src/Time.elm @@ -0,0 +1,595 @@ +effect module Time where { subscription = MySub } exposing + ( Posix + , now + , every + , posixToMillis + , millisToPosix + , Zone + , utc + , here + , toYear + , toMonth + , toDay + , toWeekday + , toHour + , toMinute + , toSecond + , toMillis + , Month(..) + , Weekday(..) + , customZone + , getZoneName + , ZoneName(..) + ) + + +{-| Library for working with time and time zones. + +# Time +@docs Posix, now, every, posixToMillis, millisToPosix + +# Time Zones +@docs Zone, utc, here + +# Human Times +@docs toYear, toMonth, toDay, toWeekday, toHour, toMinute, toSecond, toMillis + +# Weeks and Months +@docs Weekday, Month + +# For Package Authors +@docs customZone, getZoneName, ZoneName + +-} + + +import Basics exposing (..) +import Dict +import Elm.Kernel.Time +import List exposing ((::)) +import Maybe exposing (Maybe(..)) +import Platform +import Platform.Sub exposing (Sub) +import Process +import String exposing (String) +import Task exposing (Task) + + + +-- POSIX + + +{-| A computer representation of time. It is the same all over Earth, so if we +have a phone call or meeting at a certain POSIX time, there is no ambiguity. + +It is very hard for humans to _read_ a POSIX time though, so we use functions +like [`toHour`](#toHour) and [`toMinute`](#toMinute) to `view` them. +-} +type Posix = Posix Int + + +{-| Get the POSIX time at the moment when this task is run. +-} +now : Task x Posix +now = + Elm.Kernel.Time.now millisToPosix + + +{-| Turn a `Posix` time into the number of milliseconds since 1970 January 1 +at 00:00:00 UTC. It was a Thursday. +-} +posixToMillis : Posix -> Int +posixToMillis (Posix millis) = + millis + + +{-| Turn milliseconds into a `Posix` time. +-} +millisToPosix : Int -> Posix +millisToPosix = + Posix + + + +-- TIME ZONES + + +{-| Information about a particular time zone. + +The [IANA Time Zone Database][iana] tracks things like UTC offsets and +daylight-saving rules so that you can turn a `Posix` time into local times +within a time zone. + +See [`utc`](#utc) and [`here`](#here) to learn how to obtain `Zone` values. + +[iana]: https://www.iana.org/time-zones +-} +type Zone = + Zone Int (List Era) + + +-- TODO: add this note back to `Zone` docs when it is true +-- +-- Did you know that in California the times change from 3pm PST to 3pm PDT to +-- capture whether it is daylight-saving time? The database tracks those +-- abbreviation changes too. (Tons of time zones do that actually.) +-- + + +{-| Currently the public API only needs: + +- `start` is the beginning of this `Era` in "minutes since the Unix Epoch" +- `offset` is the UTC offset of this `Era` in minutes + +But eventually, it will make sense to have `abbr : String` for `PST` vs `PDT` +-} +type alias Era = + { start : Int + , offset : Int + } + + +{-| The time zone for Coordinated Universal Time ([UTC][]) + +The `utc` zone has no time adjustments. It never observes daylight-saving +time and it never shifts around based on political restructuring. + +[UTC]: https://en.wikipedia.org/wiki/Coordinated_Universal_Time +-} +utc : Zone +utc = + Zone 0 [] + + +{-| Produce a `Zone` based on the current UTC offset. You can use this to figure +out what day it is where you are: + + import Task exposing (Task) + import Time + + whatDayIsIt : Task x Int + whatDayIsIt = + Task.map2 Time.toDay Time.here Time.now + +**Accuracy Note:** This function can only give time zones like `Etc/GMT+9` or +`Etc/GMT-6`. It cannot give you `Europe/Stockholm`, `Asia/Tokyo`, or any other +normal time zone from the [full list][tz] due to limitations in JavaScript. +For example, if you run `here` in New York City, the resulting `Zone` will +never be `America/New_York`. Instead you get `Etc/GMT-5` or `Etc/GMT-4` +depending on Daylight Saving Time. So even though browsers must have internal +access to `America/New_York` to figure out that offset, there is no public API +to get the full information. This means the `Zone` you get from this function +will act weird if (1) an application stays open across a Daylight Saving Time +boundary or (2) you try to use it on historical data. + +**Future Note:** We can improve `here` when there is good browser support for +JavaScript functions that (1) expose the IANA time zone database and (2) let +you ask the time zone of the computer. The committee that reviews additions to +JavaScript is called TC39, and I encourage you to push for these capabilities! I +cannot do it myself unfortunately. + +**Alternatives:** See the `customZone` docs to learn how to implement stopgaps. + +[tz]: https://en.wikipedia.org/wiki/List_of_tz_database_time_zones +-} +here : Task x Zone +here = + Elm.Kernel.Time.here () + + + +-- DATES + + +{-| What year is it?! + + import Time exposing (toYear, utc, millisToPosix) + + toYear utc (millisToPosix 0) == 1970 + toYear nyc (millisToPosix 0) == 1969 + + -- pretend `nyc` is the `Zone` for America/New_York. +-} +toYear : Zone -> Posix -> Int +toYear zone time = + (toCivil (toAdjustedMinutes zone time)).year + + +{-| What month is it?! + + import Time exposing (toMonth, utc, millisToPosix) + + toMonth utc (millisToPosix 0) == Jan + toMonth nyc (millisToPosix 0) == Dec + + -- pretend `nyc` is the `Zone` for America/New_York. +-} +toMonth : Zone -> Posix -> Month +toMonth zone time = + case (toCivil (toAdjustedMinutes zone time)).month of + 1 -> Jan + 2 -> Feb + 3 -> Mar + 4 -> Apr + 5 -> May + 6 -> Jun + 7 -> Jul + 8 -> Aug + 9 -> Sep + 10 -> Oct + 11 -> Nov + _ -> Dec + + +{-| What day is it?! (Days go from 1 to 31) + + import Time exposing (toDay, utc, millisToPosix) + + toDay utc (millisToPosix 0) == 1 + toDay nyc (millisToPosix 0) == 31 + + -- pretend `nyc` is the `Zone` for America/New_York. + +-} +toDay : Zone -> Posix -> Int +toDay zone time = + (toCivil (toAdjustedMinutes zone time)).day + + +{-| What day of the week is it? + + import Time exposing (toWeekday, utc, millisToPosix) + + toWeekday utc (millisToPosix 0) == Thu + toWeekday nyc (millisToPosix 0) == Wed + + -- pretend `nyc` is the `Zone` for America/New_York. +-} +toWeekday : Zone -> Posix -> Weekday +toWeekday zone time = + case modBy 7 (flooredDiv (toAdjustedMinutes zone time) (60 * 24)) of + 0 -> Thu + 1 -> Fri + 2 -> Sat + 3 -> Sun + 4 -> Mon + 5 -> Tue + _ -> Wed + + +{-| What hour is it? (From 0 to 23) + + import Time exposing (toHour, utc, millisToPosix) + + toHour utc (millisToPosix 0) == 0 -- 12am + toHour nyc (millisToPosix 0) == 19 -- 7pm + + -- pretend `nyc` is the `Zone` for America/New_York. +-} +toHour : Zone -> Posix -> Int +toHour zone time = + modBy 24 (flooredDiv (toAdjustedMinutes zone time) 60) + + +{-| What minute is it? (From 0 to 59) + + import Time exposing (toMinute, utc, millisToPosix) + + toMinute utc (millisToPosix 0) == 0 + +This can be different in different time zones. Some time zones are offset +by 30 or 45 minutes! +-} +toMinute : Zone -> Posix -> Int +toMinute zone time = + modBy 60 (toAdjustedMinutes zone time) + + +{-| What second is it? + + import Time exposing (toSecond, utc, millisToPosix) + + toSecond utc (millisToPosix 0) == 0 + toSecond utc (millisToPosix 1234) == 1 + toSecond utc (millisToPosix 5678) == 5 +-} +toSecond : Zone -> Posix -> Int +toSecond _ time = + modBy 60 (flooredDiv (posixToMillis time) 1000) + + +{-| + import Time exposing (toMillis, utc, millisToPosix) + + toMillis utc (millisToPosix 0) == 0 + toMillis utc (millisToPosix 1234) == 234 + toMillis utc (millisToPosix 5678) == 678 +-} +toMillis : Zone -> Posix -> Int +toMillis _ time = + modBy 1000 (posixToMillis time) + + + +-- DATE HELPERS + + +toAdjustedMinutes : Zone -> Posix -> Int +toAdjustedMinutes (Zone defaultOffset eras) time = + toAdjustedMinutesHelp defaultOffset (flooredDiv (posixToMillis time) 60000) eras + + +toAdjustedMinutesHelp : Int -> Int -> List Era -> Int +toAdjustedMinutesHelp defaultOffset posixMinutes eras = + case eras of + [] -> + posixMinutes + defaultOffset + + era :: olderEras -> + if era.start < posixMinutes then + posixMinutes + era.offset + else + toAdjustedMinutesHelp defaultOffset posixMinutes olderEras + + +toCivil : Int -> { year : Int, month : Int, day : Int } +toCivil minutes = + let + rawDay = flooredDiv minutes (60 * 24) + 719468 + era = (if rawDay >= 0 then rawDay else rawDay - 146096) // 146097 + dayOfEra = rawDay - era * 146097 -- [0, 146096] + yearOfEra = (dayOfEra - dayOfEra // 1460 + dayOfEra // 36524 - dayOfEra // 146096) // 365 -- [0, 399] + year = yearOfEra + era * 400 + dayOfYear = dayOfEra - (365 * yearOfEra + yearOfEra // 4 - yearOfEra // 100) -- [0, 365] + mp = (5 * dayOfYear + 2) // 153 -- [0, 11] + month = mp + (if mp < 10 then 3 else -9) -- [1, 12] + in + { year = year + (if month <= 2 then 1 else 0) + , month = month + , day = dayOfYear - (153 * mp + 2) // 5 + 1 -- [1, 31] + } + + +flooredDiv : Int -> Float -> Int +flooredDiv numerator denominator = + floor (toFloat numerator / denominator) + + + +-- WEEKDAYS AND MONTHS + + +{-| Represents a `Weekday` so that you can convert it to a `String` or `Int` +however you please. For example, if you need the Japanese representation, you +can say: + + toJapaneseWeekday : Weekday -> String + toJapaneseWeekday weekday = + case weekday of + Mon -> "月" + Tue -> "火" + Wed -> "水" + Thu -> "木" + Fri -> "金" + Sat -> "土" + Sun -> "日" +-} +type Weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun + + +{-| Represents a `Month` so that you can convert it to a `String` or `Int` +however you please. For example, if you need the Danish representation, you +can say: + + toDanishMonth : Month -> String + toDanishMonth month = + case month of + Jan -> "januar" + Feb -> "februar" + Mar -> "marts" + Apr -> "april" + May -> "maj" + Jun -> "juni" + Jul -> "juli" + Aug -> "august" + Sep -> "september" + Oct -> "oktober" + Nov -> "november" + Dec -> "december" +-} +type Month = Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec + + + +-- SUBSCRIPTIONS + + +{-| Get the current time periodically. How often though? Well, you provide an +interval in milliseconds (like `1000` for a second or `60 * 1000` for a minute +or `60 * 60 * 1000` for an hour) and that is how often you get a new time! + +Check out [this example](https://elm-lang.org/examples/time) to see how to use +it in an application. + +**This function is not for animation.** Use the [`onAnimationFrame`][af] +function for that sort of thing! It syncs up with repaints and will end up +being much smoother for any moving visuals. + +[af]: /packages/elm/browser/latest/Browser-Events#onAnimationFrame +-} +every : Float -> (Posix -> msg) -> Sub msg +every interval tagger = + subscription (Every interval tagger) + + +type MySub msg = + Every Float (Posix -> msg) + + +subMap : (a -> b) -> MySub a -> MySub b +subMap f (Every interval tagger) = + Every interval (f << tagger) + + + +-- EFFECT MANAGER + + +type alias State msg = + { taggers : Taggers msg + , processes : Processes + } + + +type alias Processes = + Dict.Dict Float Platform.ProcessId + + +type alias Taggers msg = + Dict.Dict Float (List (Posix -> msg)) + + +init : Task Never (State msg) +init = + Task.succeed (State Dict.empty Dict.empty) + + +onEffects : Platform.Router msg Float -> List (MySub msg) -> State msg -> Task Never (State msg) +onEffects router subs {processes} = + let + newTaggers = + List.foldl addMySub Dict.empty subs + + leftStep interval taggers (spawns, existing, kills) = + ( interval :: spawns, existing, kills ) + + bothStep interval taggers id (spawns, existing, kills) = + ( spawns, Dict.insert interval id existing, kills ) + + rightStep _ id (spawns, existing, kills) = + ( spawns, existing, Task.andThen (\_ -> kills) (Process.kill id) ) + + (spawnList, existingDict, killTask) = + Dict.merge + leftStep + bothStep + rightStep + newTaggers + processes + ([], Dict.empty, Task.succeed ()) + in + killTask + |> Task.andThen (\_ -> spawnHelp router spawnList existingDict) + |> Task.andThen (\newProcesses -> Task.succeed (State newTaggers newProcesses)) + + +addMySub : MySub msg -> Taggers msg -> Taggers msg +addMySub (Every interval tagger) state = + case Dict.get interval state of + Nothing -> + Dict.insert interval [tagger] state + + Just taggers -> + Dict.insert interval (tagger :: taggers) state + + +spawnHelp : Platform.Router msg Float -> List Float -> Processes -> Task.Task x Processes +spawnHelp router intervals processes = + case intervals of + [] -> + Task.succeed processes + + interval :: rest -> + let + spawnTimer = + Process.spawn (setInterval interval (Platform.sendToSelf router interval)) + + spawnRest id = + spawnHelp router rest (Dict.insert interval id processes) + in + spawnTimer + |> Task.andThen spawnRest + + +onSelfMsg : Platform.Router msg Float -> Float -> State msg -> Task Never (State msg) +onSelfMsg router interval state = + case Dict.get interval state.taggers of + Nothing -> + Task.succeed state + + Just taggers -> + let + tellTaggers time = + Task.sequence (List.map (\tagger -> Platform.sendToApp router (tagger time)) taggers) + in + now + |> Task.andThen tellTaggers + |> Task.andThen (\_ -> Task.succeed state) + + +setInterval : Float -> Task Never () -> Task x Never +setInterval = + Elm.Kernel.Time.setInterval + + + +-- FOR PACKAGE AUTHORS + + + +{-| **Intended for package authors.** + +The documentation of [`here`](#here) explains that it has certain accuracy +limitations that block on adding new APIs to JavaScript. The `customZone` +function is a stopgap that takes: + +1. A default offset in minutes. So `Etc/GMT-5` is `customZone (-5 * 60) []` +and `Etc/GMT+9` is `customZone (9 * 60) []`. +2. A list of exceptions containing their `start` time in "minutes since the Unix +epoch" and their `offset` in "minutes from UTC" + +Human times will be based on the nearest `start`, falling back on the default +offset if the time is older than all of the exceptions. + +When paired with `getZoneName`, this allows you to load the real IANA time zone +database however you want: HTTP, cache, hardcode, etc. + +**Note:** If you use this, please share your work in an Elm community forum! +I am sure others would like to hear about it, and more experience reports will +help me and the any potential TC39 proposal. +-} +customZone : Int -> List { start : Int, offset : Int } -> Zone +customZone = + Zone + + +{-| **Intended for package authors.** + +Use `Intl.DateTimeFormat().resolvedOptions().timeZone` to try to get names +like `Europe/Moscow` or `America/Havana`. From there you can look it up in any +IANA data you loaded yourself. +-} +getZoneName : Task x ZoneName +getZoneName = + Elm.Kernel.Time.getZoneName () + + +{-| **Intended for package authors.** + +The `getZoneName` function relies on a JavaScript API that is not supported +in all browsers yet, so it can return the following: + + -- in more recent browsers + Name "Europe/Moscow" + Name "America/Havana" + + -- in older browsers + Offset 180 + Offset -300 + +So if the real info is not available, it will tell you the current UTC offset +in minutes, just like what `here` uses to make zones like `customZone -60 []`. +-} +type ZoneName + = Name String + | Offset Int From 926dac44ecf45b9cd9edbd8aeccb7a2948e1d9ac Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 19 Apr 2020 13:35:15 +0100 Subject: [PATCH 151/170] fix bug with kernel import see https://github.com/elm/time/pull/26 --- src/Elm/Kernel/Time.js | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Elm/Kernel/Time.js b/src/Elm/Kernel/Time.js index 9ee3056f..da795553 100644 --- a/src/Elm/Kernel/Time.js +++ b/src/Elm/Kernel/Time.js @@ -2,7 +2,7 @@ import Time exposing (customZone, Name, Offset) import Elm.Kernel.List exposing (Nil) -import Elm.Kernel.Scheduler exposing (binding, succeed) +import Elm.Kernel.Scheduler exposing (binding, succeed, rawSpawn) */ @@ -19,7 +19,7 @@ var _Time_setInterval = F2(function(interval, task) { return __Scheduler_binding(function(callback) { - var id = setInterval(function() { _Scheduler_rawSpawn(task); }, interval); + var id = setInterval(function() { __Scheduler_rawSpawn(task); }, interval); return function() { clearInterval(id); }; }); }); From f90617a19773e5eb966a6b7178bda7c4aab1388d Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 19 Apr 2020 13:36:44 +0100 Subject: [PATCH 152/170] format --- src/Elm/Kernel/Time.js | 65 +++--- src/Time.elm | 518 ++++++++++++++++++++++++++--------------- 2 files changed, 360 insertions(+), 223 deletions(-) diff --git a/src/Elm/Kernel/Time.js b/src/Elm/Kernel/Time.js index da795553..4112f693 100644 --- a/src/Elm/Kernel/Time.js +++ b/src/Elm/Kernel/Time.js @@ -6,47 +6,38 @@ import Elm.Kernel.Scheduler exposing (binding, succeed, rawSpawn) */ - -function _Time_now(millisToPosix) -{ - return __Scheduler_binding(function(callback) - { - callback(__Scheduler_succeed(millisToPosix(Date.now()))); - }); +function _Time_now(millisToPosix) { + return __Scheduler_binding(function (callback) { + callback(__Scheduler_succeed(millisToPosix(Date.now()))); + }); } -var _Time_setInterval = F2(function(interval, task) -{ - return __Scheduler_binding(function(callback) - { - var id = setInterval(function() { __Scheduler_rawSpawn(task); }, interval); - return function() { clearInterval(id); }; - }); +var _Time_setInterval = F2(function (interval, task) { + return __Scheduler_binding(function (callback) { + var id = setInterval(function () { + __Scheduler_rawSpawn(task); + }, interval); + return function () { + clearInterval(id); + }; + }); }); -function _Time_here() -{ - return __Scheduler_binding(function(callback) - { - callback(__Scheduler_succeed( - A2(__Time_customZone, -(new Date().getTimezoneOffset()), __List_Nil) - )); - }); +function _Time_here() { + return __Scheduler_binding(function (callback) { + callback( + __Scheduler_succeed(A2(__Time_customZone, -new Date().getTimezoneOffset(), __List_Nil)) + ); + }); } - -function _Time_getZoneName() -{ - return __Scheduler_binding(function(callback) - { - try - { - var name = __Time_Name(Intl.DateTimeFormat().resolvedOptions().timeZone); - } - catch (e) - { - var name = __Time_Offset(new Date().getTimezoneOffset()); - } - callback(__Scheduler_succeed(name)); - }); +function _Time_getZoneName() { + return __Scheduler_binding(function (callback) { + try { + var name = __Time_Name(Intl.DateTimeFormat().resolvedOptions().timeZone); + } catch (e) { + var name = __Time_Offset(new Date().getTimezoneOffset()); + } + callback(__Scheduler_succeed(name)); + }); } diff --git a/src/Time.elm b/src/Time.elm index 12db3139..a2f8502d 100644 --- a/src/Time.elm +++ b/src/Time.elm @@ -1,48 +1,40 @@ effect module Time where { subscription = MySub } exposing - ( Posix - , now - , every - , posixToMillis - , millisToPosix - , Zone - , utc - , here - , toYear - , toMonth - , toDay - , toWeekday - , toHour - , toMinute - , toSecond - , toMillis - , Month(..) - , Weekday(..) - , customZone - , getZoneName - , ZoneName(..) - ) - + ( Posix, now, every, posixToMillis, millisToPosix + , Zone, utc, here + , toYear, toMonth, toDay, toWeekday, toHour, toMinute, toSecond, toMillis + , Weekday(..), Month(..) + , customZone, getZoneName, ZoneName(..) + ) {-| Library for working with time and time zones. + # Time + @docs Posix, now, every, posixToMillis, millisToPosix + # Time Zones + @docs Zone, utc, here + # Human Times + @docs toYear, toMonth, toDay, toWeekday, toHour, toMinute, toSecond, toMillis + # Weeks and Months + @docs Weekday, Month + # For Package Authors + @docs customZone, getZoneName, ZoneName -} - import Basics exposing (..) import Dict import Elm.Kernel.Time @@ -64,15 +56,17 @@ have a phone call or meeting at a certain POSIX time, there is no ambiguity. It is very hard for humans to _read_ a POSIX time though, so we use functions like [`toHour`](#toHour) and [`toMinute`](#toMinute) to `view` them. + -} -type Posix = Posix Int +type Posix + = Posix Int {-| Get the POSIX time at the moment when this task is run. -} now : Task x Posix now = - Elm.Kernel.Time.now millisToPosix + Elm.Kernel.Time.now millisToPosix {-| Turn a `Posix` time into the number of milliseconds since 1970 January 1 @@ -80,14 +74,14 @@ at 00:00:00 UTC. It was a Thursday. -} posixToMillis : Posix -> Int posixToMillis (Posix millis) = - millis + millis {-| Turn milliseconds into a `Posix` time. -} millisToPosix : Int -> Posix millisToPosix = - Posix + Posix @@ -103,9 +97,11 @@ within a time zone. See [`utc`](#utc) and [`here`](#here) to learn how to obtain `Zone` values. [iana]: https://www.iana.org/time-zones + -} -type Zone = - Zone Int (List Era) +type Zone + = Zone Int (List Era) + -- TODO: add this note back to `Zone` docs when it is true @@ -118,27 +114,29 @@ type Zone = {-| Currently the public API only needs: -- `start` is the beginning of this `Era` in "minutes since the Unix Epoch" -- `offset` is the UTC offset of this `Era` in minutes + - `start` is the beginning of this `Era` in "minutes since the Unix Epoch" + - `offset` is the UTC offset of this `Era` in minutes But eventually, it will make sense to have `abbr : String` for `PST` vs `PDT` + -} type alias Era = - { start : Int - , offset : Int - } + { start : Int + , offset : Int + } -{-| The time zone for Coordinated Universal Time ([UTC][]) +{-| The time zone for Coordinated Universal Time ([UTC]) The `utc` zone has no time adjustments. It never observes daylight-saving time and it never shifts around based on political restructuring. [UTC]: https://en.wikipedia.org/wiki/Coordinated_Universal_Time + -} utc : Zone utc = - Zone 0 [] + Zone 0 [] {-| Produce a `Zone` based on the current UTC offset. You can use this to figure @@ -149,7 +147,7 @@ out what day it is where you are: whatDayIsIt : Task x Int whatDayIsIt = - Task.map2 Time.toDay Time.here Time.now + Task.map2 Time.toDay Time.here Time.now **Accuracy Note:** This function can only give time zones like `Etc/GMT+9` or `Etc/GMT-6`. It cannot give you `Europe/Stockholm`, `Asia/Tokyo`, or any other @@ -171,10 +169,11 @@ cannot do it myself unfortunately. **Alternatives:** See the `customZone` docs to learn how to implement stopgaps. [tz]: https://en.wikipedia.org/wiki/List_of_tz_database_time_zones + -} here : Task x Zone here = - Elm.Kernel.Time.here () + Elm.Kernel.Time.here () @@ -189,10 +188,11 @@ here = toYear nyc (millisToPosix 0) == 1969 -- pretend `nyc` is the `Zone` for America/New_York. + -} toYear : Zone -> Posix -> Int toYear zone time = - (toCivil (toAdjustedMinutes zone time)).year + (toCivil (toAdjustedMinutes zone time)).year {-| What month is it?! @@ -203,22 +203,46 @@ toYear zone time = toMonth nyc (millisToPosix 0) == Dec -- pretend `nyc` is the `Zone` for America/New_York. + -} toMonth : Zone -> Posix -> Month toMonth zone time = - case (toCivil (toAdjustedMinutes zone time)).month of - 1 -> Jan - 2 -> Feb - 3 -> Mar - 4 -> Apr - 5 -> May - 6 -> Jun - 7 -> Jul - 8 -> Aug - 9 -> Sep - 10 -> Oct - 11 -> Nov - _ -> Dec + case (toCivil (toAdjustedMinutes zone time)).month of + 1 -> + Jan + + 2 -> + Feb + + 3 -> + Mar + + 4 -> + Apr + + 5 -> + May + + 6 -> + Jun + + 7 -> + Jul + + 8 -> + Aug + + 9 -> + Sep + + 10 -> + Oct + + 11 -> + Nov + + _ -> + Dec {-| What day is it?! (Days go from 1 to 31) @@ -233,7 +257,7 @@ toMonth zone time = -} toDay : Zone -> Posix -> Int toDay zone time = - (toCivil (toAdjustedMinutes zone time)).day + (toCivil (toAdjustedMinutes zone time)).day {-| What day of the week is it? @@ -244,17 +268,31 @@ toDay zone time = toWeekday nyc (millisToPosix 0) == Wed -- pretend `nyc` is the `Zone` for America/New_York. + -} toWeekday : Zone -> Posix -> Weekday toWeekday zone time = - case modBy 7 (flooredDiv (toAdjustedMinutes zone time) (60 * 24)) of - 0 -> Thu - 1 -> Fri - 2 -> Sat - 3 -> Sun - 4 -> Mon - 5 -> Tue - _ -> Wed + case modBy 7 (flooredDiv (toAdjustedMinutes zone time) (60 * 24)) of + 0 -> + Thu + + 1 -> + Fri + + 2 -> + Sat + + 3 -> + Sun + + 4 -> + Mon + + 5 -> + Tue + + _ -> + Wed {-| What hour is it? (From 0 to 23) @@ -265,10 +303,11 @@ toWeekday zone time = toHour nyc (millisToPosix 0) == 19 -- 7pm -- pretend `nyc` is the `Zone` for America/New_York. + -} toHour : Zone -> Posix -> Int toHour zone time = - modBy 24 (flooredDiv (toAdjustedMinutes zone time) 60) + modBy 24 (flooredDiv (toAdjustedMinutes zone time) 60) {-| What minute is it? (From 0 to 59) @@ -279,10 +318,11 @@ toHour zone time = This can be different in different time zones. Some time zones are offset by 30 or 45 minutes! + -} toMinute : Zone -> Posix -> Int toMinute zone time = - modBy 60 (toAdjustedMinutes zone time) + modBy 60 (toAdjustedMinutes zone time) {-| What second is it? @@ -292,22 +332,25 @@ toMinute zone time = toSecond utc (millisToPosix 0) == 0 toSecond utc (millisToPosix 1234) == 1 toSecond utc (millisToPosix 5678) == 5 + -} toSecond : Zone -> Posix -> Int toSecond _ time = - modBy 60 (flooredDiv (posixToMillis time) 1000) + modBy 60 (flooredDiv (posixToMillis time) 1000) {-| + import Time exposing (toMillis, utc, millisToPosix) toMillis utc (millisToPosix 0) == 0 toMillis utc (millisToPosix 1234) == 234 toMillis utc (millisToPosix 5678) == 678 + -} toMillis : Zone -> Posix -> Int toMillis _ time = - modBy 1000 (posixToMillis time) + modBy 1000 (posixToMillis time) @@ -316,43 +359,84 @@ toMillis _ time = toAdjustedMinutes : Zone -> Posix -> Int toAdjustedMinutes (Zone defaultOffset eras) time = - toAdjustedMinutesHelp defaultOffset (flooredDiv (posixToMillis time) 60000) eras + toAdjustedMinutesHelp defaultOffset (flooredDiv (posixToMillis time) 60000) eras toAdjustedMinutesHelp : Int -> Int -> List Era -> Int toAdjustedMinutesHelp defaultOffset posixMinutes eras = - case eras of - [] -> - posixMinutes + defaultOffset + case eras of + [] -> + posixMinutes + defaultOffset + + era :: olderEras -> + if era.start < posixMinutes then + posixMinutes + era.offset - era :: olderEras -> - if era.start < posixMinutes then - posixMinutes + era.offset - else - toAdjustedMinutesHelp defaultOffset posixMinutes olderEras + else + toAdjustedMinutesHelp defaultOffset posixMinutes olderEras toCivil : Int -> { year : Int, month : Int, day : Int } toCivil minutes = - let - rawDay = flooredDiv minutes (60 * 24) + 719468 - era = (if rawDay >= 0 then rawDay else rawDay - 146096) // 146097 - dayOfEra = rawDay - era * 146097 -- [0, 146096] - yearOfEra = (dayOfEra - dayOfEra // 1460 + dayOfEra // 36524 - dayOfEra // 146096) // 365 -- [0, 399] - year = yearOfEra + era * 400 - dayOfYear = dayOfEra - (365 * yearOfEra + yearOfEra // 4 - yearOfEra // 100) -- [0, 365] - mp = (5 * dayOfYear + 2) // 153 -- [0, 11] - month = mp + (if mp < 10 then 3 else -9) -- [1, 12] - in - { year = year + (if month <= 2 then 1 else 0) - , month = month - , day = dayOfYear - (153 * mp + 2) // 5 + 1 -- [1, 31] - } + let + rawDay = + flooredDiv minutes (60 * 24) + 719468 + + era = + (if rawDay >= 0 then + rawDay + + else + rawDay - 146096 + ) + // 146097 + + dayOfEra = + rawDay - era * 146097 + + -- [0, 146096] + yearOfEra = + (dayOfEra - dayOfEra // 1460 + dayOfEra // 36524 - dayOfEra // 146096) // 365 + + -- [0, 399] + year = + yearOfEra + era * 400 + + dayOfYear = + dayOfEra - (365 * yearOfEra + yearOfEra // 4 - yearOfEra // 100) + + -- [0, 365] + mp = + (5 * dayOfYear + 2) // 153 + + -- [0, 11] + month = + mp + + (if mp < 10 then + 3 + + else + -9 + ) + + -- [1, 12] + in + { year = + year + + (if month <= 2 then + 1 + + else + 0 + ) + , month = month + , day = dayOfYear - (153 * mp + 2) // 5 + 1 -- [1, 31] + } flooredDiv : Int -> Float -> Int flooredDiv numerator denominator = - floor (toFloat numerator / denominator) + floor (toFloat numerator / denominator) @@ -365,16 +449,37 @@ can say: toJapaneseWeekday : Weekday -> String toJapaneseWeekday weekday = - case weekday of - Mon -> "月" - Tue -> "火" - Wed -> "水" - Thu -> "木" - Fri -> "金" - Sat -> "土" - Sun -> "日" + case weekday of + Mon -> + "月" + + Tue -> + "火" + + Wed -> + "水" + + Thu -> + "木" + + Fri -> + "金" + + Sat -> + "土" + + Sun -> + "日" + -} -type Weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun +type Weekday + = Mon + | Tue + | Wed + | Thu + | Fri + | Sat + | Sun {-| Represents a `Month` so that you can convert it to a `String` or `Int` @@ -383,21 +488,57 @@ can say: toDanishMonth : Month -> String toDanishMonth month = - case month of - Jan -> "januar" - Feb -> "februar" - Mar -> "marts" - Apr -> "april" - May -> "maj" - Jun -> "juni" - Jul -> "juli" - Aug -> "august" - Sep -> "september" - Oct -> "oktober" - Nov -> "november" - Dec -> "december" + case month of + Jan -> + "januar" + + Feb -> + "februar" + + Mar -> + "marts" + + Apr -> + "april" + + May -> + "maj" + + Jun -> + "juni" + + Jul -> + "juli" + + Aug -> + "august" + + Sep -> + "september" + + Oct -> + "oktober" + + Nov -> + "november" + + Dec -> + "december" + -} -type Month = Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec +type Month + = Jan + | Feb + | Mar + | Apr + | May + | Jun + | Jul + | Aug + | Sep + | Oct + | Nov + | Dec @@ -416,19 +557,20 @@ function for that sort of thing! It syncs up with repaints and will end up being much smoother for any moving visuals. [af]: /packages/elm/browser/latest/Browser-Events#onAnimationFrame + -} every : Float -> (Posix -> msg) -> Sub msg every interval tagger = - subscription (Every interval tagger) + subscription (Every interval tagger) -type MySub msg = - Every Float (Posix -> msg) +type MySub msg + = Every Float (Posix -> msg) subMap : (a -> b) -> MySub a -> MySub b subMap f (Every interval tagger) = - Every interval (f << tagger) + Every interval (f << tagger) @@ -436,117 +578,116 @@ subMap f (Every interval tagger) = type alias State msg = - { taggers : Taggers msg - , processes : Processes - } + { taggers : Taggers msg + , processes : Processes + } type alias Processes = - Dict.Dict Float Platform.ProcessId + Dict.Dict Float Platform.ProcessId type alias Taggers msg = - Dict.Dict Float (List (Posix -> msg)) + Dict.Dict Float (List (Posix -> msg)) init : Task Never (State msg) init = - Task.succeed (State Dict.empty Dict.empty) + Task.succeed (State Dict.empty Dict.empty) onEffects : Platform.Router msg Float -> List (MySub msg) -> State msg -> Task Never (State msg) -onEffects router subs {processes} = - let - newTaggers = - List.foldl addMySub Dict.empty subs - - leftStep interval taggers (spawns, existing, kills) = - ( interval :: spawns, existing, kills ) - - bothStep interval taggers id (spawns, existing, kills) = - ( spawns, Dict.insert interval id existing, kills ) - - rightStep _ id (spawns, existing, kills) = - ( spawns, existing, Task.andThen (\_ -> kills) (Process.kill id) ) - - (spawnList, existingDict, killTask) = - Dict.merge - leftStep - bothStep - rightStep - newTaggers - processes - ([], Dict.empty, Task.succeed ()) - in +onEffects router subs { processes } = + let + newTaggers = + List.foldl addMySub Dict.empty subs + + leftStep interval taggers ( spawns, existing, kills ) = + ( interval :: spawns, existing, kills ) + + bothStep interval taggers id ( spawns, existing, kills ) = + ( spawns, Dict.insert interval id existing, kills ) + + rightStep _ id ( spawns, existing, kills ) = + ( spawns, existing, Task.andThen (\_ -> kills) (Process.kill id) ) + + ( spawnList, existingDict, killTask ) = + Dict.merge + leftStep + bothStep + rightStep + newTaggers + processes + ( [], Dict.empty, Task.succeed () ) + in killTask - |> Task.andThen (\_ -> spawnHelp router spawnList existingDict) - |> Task.andThen (\newProcesses -> Task.succeed (State newTaggers newProcesses)) + |> Task.andThen (\_ -> spawnHelp router spawnList existingDict) + |> Task.andThen (\newProcesses -> Task.succeed (State newTaggers newProcesses)) addMySub : MySub msg -> Taggers msg -> Taggers msg addMySub (Every interval tagger) state = - case Dict.get interval state of - Nothing -> - Dict.insert interval [tagger] state + case Dict.get interval state of + Nothing -> + Dict.insert interval [ tagger ] state - Just taggers -> - Dict.insert interval (tagger :: taggers) state + Just taggers -> + Dict.insert interval (tagger :: taggers) state spawnHelp : Platform.Router msg Float -> List Float -> Processes -> Task.Task x Processes spawnHelp router intervals processes = - case intervals of - [] -> - Task.succeed processes + case intervals of + [] -> + Task.succeed processes - interval :: rest -> - let - spawnTimer = - Process.spawn (setInterval interval (Platform.sendToSelf router interval)) + interval :: rest -> + let + spawnTimer = + Process.spawn (setInterval interval (Platform.sendToSelf router interval)) - spawnRest id = - spawnHelp router rest (Dict.insert interval id processes) - in - spawnTimer - |> Task.andThen spawnRest + spawnRest id = + spawnHelp router rest (Dict.insert interval id processes) + in + spawnTimer + |> Task.andThen spawnRest onSelfMsg : Platform.Router msg Float -> Float -> State msg -> Task Never (State msg) onSelfMsg router interval state = - case Dict.get interval state.taggers of - Nothing -> - Task.succeed state + case Dict.get interval state.taggers of + Nothing -> + Task.succeed state - Just taggers -> - let - tellTaggers time = - Task.sequence (List.map (\tagger -> Platform.sendToApp router (tagger time)) taggers) - in - now - |> Task.andThen tellTaggers - |> Task.andThen (\_ -> Task.succeed state) + Just taggers -> + let + tellTaggers time = + Task.sequence (List.map (\tagger -> Platform.sendToApp router (tagger time)) taggers) + in + now + |> Task.andThen tellTaggers + |> Task.andThen (\_ -> Task.succeed state) setInterval : Float -> Task Never () -> Task x Never setInterval = - Elm.Kernel.Time.setInterval + Elm.Kernel.Time.setInterval -- FOR PACKAGE AUTHORS - {-| **Intended for package authors.** The documentation of [`here`](#here) explains that it has certain accuracy limitations that block on adding new APIs to JavaScript. The `customZone` function is a stopgap that takes: -1. A default offset in minutes. So `Etc/GMT-5` is `customZone (-5 * 60) []` -and `Etc/GMT+9` is `customZone (9 * 60) []`. -2. A list of exceptions containing their `start` time in "minutes since the Unix -epoch" and their `offset` in "minutes from UTC" +1. A default offset in minutes. So `Etc/GMT-5` is `customZone (-5 * 60) []` + and `Etc/GMT+9` is `customZone (9 * 60) []`. +2. A list of exceptions containing their `start` time in "minutes since the Unix + epoch" and their `offset` in "minutes from UTC" Human times will be based on the nearest `start`, falling back on the default offset if the time is older than all of the exceptions. @@ -557,10 +698,11 @@ database however you want: HTTP, cache, hardcode, etc. **Note:** If you use this, please share your work in an Elm community forum! I am sure others would like to hear about it, and more experience reports will help me and the any potential TC39 proposal. + -} customZone : Int -> List { start : Int, offset : Int } -> Zone customZone = - Zone + Zone {-| **Intended for package authors.** @@ -568,10 +710,11 @@ customZone = Use `Intl.DateTimeFormat().resolvedOptions().timeZone` to try to get names like `Europe/Moscow` or `America/Havana`. From there you can look it up in any IANA data you loaded yourself. + -} getZoneName : Task x ZoneName getZoneName = - Elm.Kernel.Time.getZoneName () + Elm.Kernel.Time.getZoneName () {-| **Intended for package authors.** @@ -581,15 +724,18 @@ in all browsers yet, so it can return the following: -- in more recent browsers Name "Europe/Moscow" + Name "America/Havana" -- in older browsers Offset 180 + Offset -300 So if the real info is not available, it will tell you the current UTC offset in minutes, just like what `here` uses to make zones like `customZone -60 []`. + -} type ZoneName - = Name String - | Offset Int + = Name String + | Offset Int From d79bfdbb681273b03617198e8b97f77db092e391 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 25 Apr 2020 23:10:44 +0100 Subject: [PATCH 153/170] stub time --- custom-core.sh | 4 +++- stub.py | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 1 deletion(-) create mode 100755 stub.py diff --git a/custom-core.sh b/custom-core.sh index ee51cd2a..c410b107 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -23,7 +23,7 @@ if [[ -d "$CORE_VERSIONS_DIR" ]]; then CORE_VERSION=$(ls "$CORE_VERSIONS_DIR") CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" - if [ CORE_VERSION_COUNT == 1 ] || [[ -f $CORE_PACKAGE_DIR/custom ]]; then + if [ $CORE_VERSION_COUNT == 1 ] && [[ -f $CORE_PACKAGE_DIR/custom ]] && [[ -d "$ELM_HOME/$ELM_VERSION/packages/elm/time" ]]; then printf "REFRESH " else printf "INIT " @@ -37,6 +37,8 @@ fi CORE_VERSION=$(ls $CORE_VERSIONS_DIR) CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" +./stub.py "$ELM_HOME/$ELM_VERSION/packages/elm/time" + rm -rf "$CORE_PACKAGE_DIR" > /dev/null mkdir "$CORE_PACKAGE_DIR" cp -r src "$CORE_PACKAGE_DIR"/ > /dev/null diff --git a/stub.py b/stub.py new file mode 100755 index 00000000..48607cd4 --- /dev/null +++ b/stub.py @@ -0,0 +1,54 @@ +#! /usr/bin/env python3 + +import os +import sys +import shutil +import json +import random +import string + +versions_dir = sys.argv[1] + +for v in os.listdir(versions_dir): + version = os.path.join(versions_dir, v) + src_dir = os.path.join(version, "src") + stub_file = os.path.join(version, "stub") + elm_json_path = os.path.join(version, "elm.json") + + package_name = None + with open(elm_json_path, 'r') as f: + package_name = json.load(f)["name"] + + dummy_module = "P{}".format(''.join( + [random.choice(string.ascii_letters) for n in range(32)] + )) + dummy_path = os.path.join(src_dir, "{}.elm".format(dummy_module)) + + shutil.rmtree(version) + os.makedirs(src_dir) + + with open(stub_file, 'w'): + pass + + with open(dummy_path, 'w') as f: + f.write("""module {} exposing (..) + +a = 2 +""".format(dummy_module)) + + with open(elm_json_path, 'w') as f: + f.write(""" {{ + "type": "package", + "name": "{}", + "summary": "Encode and decode JSON values", + "license": "BSD-3-Clause", + "version": "{}", + "exposed-modules": [ + "{}" + ], + "elm-version": "0.19.0 <= v < 0.20.0", + "dependencies": {{ + "elm/core": "1.0.0 <= v < 2.0.0" + }}, + "test-dependencies": {{}} +}}""".format(package_name, v, dummy_module)) From e4456db87bebe7cbbbdb1d4cd53df61f4170d23c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 25 Apr 2020 23:14:08 +0100 Subject: [PATCH 154/170] make time.every work --- src/Elm/Kernel/Platform.js | 74 ++++++++++++++--------- src/Elm/Kernel/Time.js | 85 +++++++++++++++++--------- src/Platform/Sub.elm | 9 ++- src/Time.elm | 119 ++++--------------------------------- 4 files changed, 120 insertions(+), 167 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index d12bba11..fc532e54 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -7,12 +7,12 @@ import Elm.Kernel.Utils exposing (Tuple0, Tuple2) import Elm.Kernel.Channel exposing (rawUnbounded, rawSend) import Elm.Kernel.Basics exposing (isDebug) import Result exposing (isOk) -import Maybe exposing (Nothing, map) +import Maybe exposing (Nothing) import Platform exposing (Task, ProcessId, initializeHelperFunctions, ImpureFunction) import Platform.Raw.Scheduler as RawScheduler exposing (rawSpawn) import Platform.Raw.Task as RawTask exposing (execImpure, andThen) import Platform.Raw.Channel as RawChannel exposing (recv) -import Platform.Scheduler as Scheduler exposing (execImpure, map) +import Platform.Scheduler as Scheduler exposing (execImpure) */ @@ -24,6 +24,15 @@ var _Platform_incomingPorts = new Map(); var _Platform_effectsQueue = []; var _Platform_effectDispatchInProgress = false; +let _Platform_spawnAfterLoadQueue = []; +const _Platform_spawnAfterLoad = (rawTask) => { + if (_Platform_spawnAfterLoadQueue == null) { + __RawScheduler_rawSpawn(rawTask); + } else { + _Platform_spawnAfterLoadQueue.push(rawTask); + } +}; + // INITIALIZE A PROGRAM const _Platform_initialize = F3((flagDecoder, args, impl) => { @@ -77,9 +86,10 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { dispatch(model, updateValue.b); }); - for (const init of _Platform_subscriptionInit) { - __RawScheduler_rawSpawn(init(__Utils_Tuple0)); + for (const f of _Platform_spawnAfterLoadQueue) { + __RawScheduler_rawSpawn(rawTask); } + _Platform_spawnAfterLoadQueue = null; cmdSender = __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp); @@ -175,7 +185,7 @@ function _Platform_outgoingPort(name, converter) { function _Platform_incomingPort(name, converter) { _Platform_checkPortName(name); - const tuple = _Platform_createSubProcess(); + const tuple = _Platform_createSubProcess((_) => __Utils_Tuple0); const key = tuple.a; const sender = tuple.b; @@ -194,34 +204,24 @@ function _Platform_incomingPort(name, converter) { }, }); - return (tagger) => { - const subData = __List_Cons(__Utils_Tuple2(key, tagger), __List_Nil); - if (__Basics_isDebug) { - return { - $: "Sub", - a: subData, - }; - } - return subData; - }; + return _Platform_subscription(key); } // Functions exported to elm -const _Platform_subscriptionMap = new Map(); -const _Platform_subscriptionInit = []; +const _Platform_subscriptionStates = new Map(); let _Platform_subscriptionProcessIds = 0; -const _Platform_createSubProcess = (_) => { +const _Platform_createSubProcess = (onSubUpdate) => { const channel = __Channel_rawUnbounded(); const key = { id: _Platform_subscriptionProcessIds++ }; const msgHandler = (msg) => __RawTask_execImpure((_) => { - const sendToApps = _Platform_subscriptionMap.get(key); - if (__Basics_isDebug && sendToApps === undefined) { + const subscriptionState = _Platform_subscriptionStates.get(key); + if (__Basics_isDebug && subscriptionState === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); } - for (const sendToApp of sendToApps) { + for (const sendToApp of subscriptionState.__$listeners) { sendToApp(msg); } return __Utils_Tuple0; @@ -230,25 +230,31 @@ const _Platform_createSubProcess = (_) => { const onSubEffects = (_) => A2(__RawTask_andThen, onSubEffects, A2(__RawChannel_recv, msgHandler, channel.b)); - _Platform_subscriptionMap.set(key, []); - _Platform_subscriptionInit.push(onSubEffects); + _Platform_subscriptionStates.set(key, { + __$listeners: [], + __$onSubUpdate: onSubUpdate, + }); + _Platform_spawnAfterLoad(onSubEffects(__Utils_Tuple0)); return __Utils_Tuple2(key, channel.a); }; const _Platform_resetSubscriptions = (newSubs) => __Platform_ImpureFunction((_) => { - for (const sendToApps of _Platform_subscriptionMap.values()) { - sendToApps.length = 0; + for (const subState of _Platform_subscriptionStates.values()) { + subState.__$listeners.length = 0; } for (const tuple of __List_toArray(newSubs)) { const key = tuple.a; const sendToApp = tuple.b; - const sendToApps = _Platform_subscriptionMap.get(key); - if (__Basics_isDebug && sendToApps === undefined) { + const subState = _Platform_subscriptionStates.get(key); + if (__Basics_isDebug && subState.__$listeners === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); } - sendToApps.push(sendToApp); + subState.__$listeners.push(sendToApp); + } + for (const subState of _Platform_subscriptionStates.values()) { + subState.__$onSubUpdate(subState.__$listeners.length); } return __Utils_Tuple0; }); @@ -271,6 +277,18 @@ const _Platform_command = (task) => { return cmdData; }; +// subscription : SubId -> (HiddenConvertedSubType -> msg) -> Sub msg +const _Platform_subscription = (id) => (tagger) => { + const subData = __List_Cons(__Utils_Tuple2(id, tagger), __List_Nil); + if (__Basics_isDebug) { + return { + $: "Sub", + a: subData, + }; + } + return subData; +}; + // EXPORT ELM MODULES // // Have DEBUG and PROD versions so that we can (1) give nicer errors in diff --git a/src/Elm/Kernel/Time.js b/src/Elm/Kernel/Time.js index 4112f693..a8edc20d 100644 --- a/src/Elm/Kernel/Time.js +++ b/src/Elm/Kernel/Time.js @@ -1,43 +1,72 @@ /* -import Time exposing (customZone, Name, Offset) +import Time exposing (customZone, Name) import Elm.Kernel.List exposing (Nil) -import Elm.Kernel.Scheduler exposing (binding, succeed, rawSpawn) +import Elm.Kernel.Platform exposing (createSubProcess) +import Elm.Kernel.Scheduler exposing (execImpure) +import Elm.Kernel.Channel exposing (rawSend) +import Elm.Kernel.Utils exposing (Tuple0) */ function _Time_now(millisToPosix) { - return __Scheduler_binding(function (callback) { - callback(__Scheduler_succeed(millisToPosix(Date.now()))); - }); + return __Scheduler_execImpure((_) => millisToPosix(Date.now())); } -var _Time_setInterval = F2(function (interval, task) { - return __Scheduler_binding(function (callback) { - var id = setInterval(function () { - __Scheduler_rawSpawn(task); - }, interval); - return function () { - clearInterval(id); - }; - }); -}); +const _Time_intervals = new WeakMap(); + +/** + * There is no way to do clean up in js. This implementation is fundamentally + * broken as the intervals created are never cleaned up. TODO(harry): fix this. + * + * This function is impure and should _really_ return a Task. That would be a + * breaking API change though. + */ +function _Time_setInterval(interval) { + const roundedInterval = Math.round(interval); + const existingKey = _Time_intervals.get(roundedInterval); + if (existingKey !== undefined) { + return existingKey; + } else { + const handle = setInterval(() => { + A2(__Channel_rawSend, sender, Date.now()); + }, roundedInterval); + + // Unless we are carefull here, creating any Time.every subscription has + // the potential of preventing and elm app from terminating when we run in + // nodejs. We use the node specific [`TimeOut.ref()`](ref) and + // [`TimeOut.unref()`](unref) API's to ensure our app terminates. + // + // [ref]: https://nodejs.org/api/timers.html#timers_timeout_ref + // [unref]: https://nodejs.org/api/timers.html#timers_timeout_unref + const onSubReset = + typeof handle.ref === "function" + ? (n) => { + if (n == 0) { + handle.unref(); + } else { + handle.ref(); + } + return __Utils_Tuple0; + } + : (_) => __Utils_Tuple0; + + const tuple = __Platform_createSubProcess(onSubReset); + const key = tuple.a; + const sender = tuple.b; + + return key; + } +} function _Time_here() { - return __Scheduler_binding(function (callback) { - callback( - __Scheduler_succeed(A2(__Time_customZone, -new Date().getTimezoneOffset(), __List_Nil)) - ); - }); + return __Scheduler_execImpure((_) => + A2(__Time_customZone, -new Date().getTimezoneOffset(), __List_Nil) + ); } function _Time_getZoneName() { - return __Scheduler_binding(function (callback) { - try { - var name = __Time_Name(Intl.DateTimeFormat().resolvedOptions().timeZone); - } catch (e) { - var name = __Time_Offset(new Date().getTimezoneOffset()); - } - callback(__Scheduler_succeed(name)); - }); + return __Scheduler_execImpure((_) => + __Time_Name(Intl.DateTimeFormat().resolvedOptions().timeZone) + ); } diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 4576e500..0ee828e1 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -27,7 +27,6 @@ module Platform.Sub exposing -} import Basics exposing (..) -import Elm.Kernel.Platform import List import Platform.Bag as Bag @@ -54,7 +53,7 @@ into a real application! -} type Sub msg - = Sub (List ( IncomingPortId, HiddenConvertedSubType -> msg )) + = Sub (List ( SubId, HiddenConvertedSubType -> msg )) {-| Tell the runtime that there are no subscriptions. @@ -98,14 +97,14 @@ map fn (Sub data) = |> Sub -type IncomingPortId - = IncomingPortId IncomingPortId +type SubId + = SubId SubId type HiddenConvertedSubType = HiddenConvertedSubType HiddenConvertedSubType -getSubMapper : (a -> msg) -> ( IncomingPortId, HiddenConvertedSubType -> a ) -> ( IncomingPortId, HiddenConvertedSubType -> msg ) +getSubMapper : (a -> msg) -> ( SubId, HiddenConvertedSubType -> a ) -> ( SubId, HiddenConvertedSubType -> msg ) getSubMapper fn ( id, tagger ) = ( id, \hcst -> fn (tagger hcst) ) diff --git a/src/Time.elm b/src/Time.elm index a2f8502d..955dc4d9 100644 --- a/src/Time.elm +++ b/src/Time.elm @@ -1,4 +1,4 @@ -effect module Time where { subscription = MySub } exposing +module Time exposing ( Posix, now, every, posixToMillis, millisToPosix , Zone, utc, here , toYear, toMonth, toDay, toWeekday, toHour, toMinute, toSecond, toMillis @@ -37,14 +37,17 @@ effect module Time where { subscription = MySub } exposing import Basics exposing (..) import Dict +import Elm.Kernel.Platform import Elm.Kernel.Time import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform +import Platform.Raw.Channel as Channel import Platform.Sub exposing (Sub) import Process import String exposing (String) import Task exposing (Task) +import Tuple @@ -561,119 +564,23 @@ being much smoother for any moving visuals. -} every : Float -> (Posix -> msg) -> Sub msg every interval tagger = - subscription (Every interval tagger) + subscription (setInterval interval) (\f -> tagger (millisToPosix (round f))) -type MySub msg - = Every Float (Posix -> msg) +type SubId + = SubId SubId -subMap : (a -> b) -> MySub a -> MySub b -subMap f (Every interval tagger) = - Every interval (f << tagger) - - - --- EFFECT MANAGER - - -type alias State msg = - { taggers : Taggers msg - , processes : Processes - } - - -type alias Processes = - Dict.Dict Float Platform.ProcessId - - -type alias Taggers msg = - Dict.Dict Float (List (Posix -> msg)) - - -init : Task Never (State msg) -init = - Task.succeed (State Dict.empty Dict.empty) - - -onEffects : Platform.Router msg Float -> List (MySub msg) -> State msg -> Task Never (State msg) -onEffects router subs { processes } = - let - newTaggers = - List.foldl addMySub Dict.empty subs - - leftStep interval taggers ( spawns, existing, kills ) = - ( interval :: spawns, existing, kills ) - - bothStep interval taggers id ( spawns, existing, kills ) = - ( spawns, Dict.insert interval id existing, kills ) - - rightStep _ id ( spawns, existing, kills ) = - ( spawns, existing, Task.andThen (\_ -> kills) (Process.kill id) ) - - ( spawnList, existingDict, killTask ) = - Dict.merge - leftStep - bothStep - rightStep - newTaggers - processes - ( [], Dict.empty, Task.succeed () ) - in - killTask - |> Task.andThen (\_ -> spawnHelp router spawnList existingDict) - |> Task.andThen (\newProcesses -> Task.succeed (State newTaggers newProcesses)) - - -addMySub : MySub msg -> Taggers msg -> Taggers msg -addMySub (Every interval tagger) state = - case Dict.get interval state of - Nothing -> - Dict.insert interval [ tagger ] state - - Just taggers -> - Dict.insert interval (tagger :: taggers) state - - -spawnHelp : Platform.Router msg Float -> List Float -> Processes -> Task.Task x Processes -spawnHelp router intervals processes = - case intervals of - [] -> - Task.succeed processes - - interval :: rest -> - let - spawnTimer = - Process.spawn (setInterval interval (Platform.sendToSelf router interval)) - - spawnRest id = - spawnHelp router rest (Dict.insert interval id processes) - in - spawnTimer - |> Task.andThen spawnRest - - -onSelfMsg : Platform.Router msg Float -> Float -> State msg -> Task Never (State msg) -onSelfMsg router interval state = - case Dict.get interval state.taggers of - Nothing -> - Task.succeed state - - Just taggers -> - let - tellTaggers time = - Task.sequence (List.map (\tagger -> Platform.sendToApp router (tagger time)) taggers) - in - now - |> Task.andThen tellTaggers - |> Task.andThen (\_ -> Task.succeed state) - - -setInterval : Float -> Task Never () -> Task x Never +setInterval : Float -> SubId setInterval = Elm.Kernel.Time.setInterval +subscription : SubId -> (Float -> msg) -> Sub msg +subscription = + Elm.Kernel.Platform.subscription + + -- FOR PACKAGE AUTHORS From 597d47af2655b8f46097635e84eb7a4b4c6dd6e2 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 25 Apr 2020 23:28:30 +0100 Subject: [PATCH 155/170] fix runAfterLoad --- src/Elm/Kernel/Platform.js | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index fc532e54..f0568ceb 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -24,12 +24,12 @@ var _Platform_incomingPorts = new Map(); var _Platform_effectsQueue = []; var _Platform_effectDispatchInProgress = false; -let _Platform_spawnAfterLoadQueue = []; -const _Platform_spawnAfterLoad = (rawTask) => { - if (_Platform_spawnAfterLoadQueue == null) { - __RawScheduler_rawSpawn(rawTask); +let _Platform_runAfterLoadQueue = []; +const _Platform_runAfterLoad = (f) => { + if (_Platform_runAfterLoadQueue == null) { + f(); } else { - _Platform_spawnAfterLoadQueue.push(rawTask); + _Platform_runAfterLoadQueue.push(f); } }; @@ -86,10 +86,10 @@ const _Platform_initialize = F3((flagDecoder, args, impl) => { dispatch(model, updateValue.b); }); - for (const f of _Platform_spawnAfterLoadQueue) { - __RawScheduler_rawSpawn(rawTask); + for (const f of _Platform_runAfterLoadQueue) { + f(); } - _Platform_spawnAfterLoadQueue = null; + _Platform_runAfterLoadQueue = null; cmdSender = __Platform_initializeHelperFunctions.__$setupEffectsChannel(sendToApp); @@ -234,7 +234,7 @@ const _Platform_createSubProcess = (onSubUpdate) => { __$listeners: [], __$onSubUpdate: onSubUpdate, }); - _Platform_spawnAfterLoad(onSubEffects(__Utils_Tuple0)); + _Platform_runAfterLoad(() => __RawScheduler_rawSpawn(onSubEffects(__Utils_Tuple0))); return __Utils_Tuple2(key, channel.a); }; From 745a5604a4a5e62360355b6151f7e4d94d952755 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sat, 25 Apr 2020 23:29:02 +0100 Subject: [PATCH 156/170] tidy up Sub inner data types --- src/Elm/Kernel/Platform.js | 2 +- src/Platform.elm | 48 ++++---------------------------------- src/Platform/Bag.elm | 24 ------------------- src/Platform/Cmd.elm | 1 - src/Platform/Raw/Sub.elm | 16 +++++++++++++ src/Platform/Sub.elm | 14 +++-------- src/Time.elm | 9 +++---- 7 files changed, 28 insertions(+), 86 deletions(-) delete mode 100644 src/Platform/Bag.elm create mode 100644 src/Platform/Raw/Sub.elm diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index f0568ceb..48509238 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -277,7 +277,7 @@ const _Platform_command = (task) => { return cmdData; }; -// subscription : SubId -> (HiddenConvertedSubType -> msg) -> Sub msg +// subscription : RawSub.Id -> (RawSub.HiddenConvertedSubType -> msg) -> Sub msg const _Platform_subscription = (id) => (tagger) => { const subData = __List_Cons(__Utils_Tuple2(id, tagger), __List_Nil); if (__Basics_isDebug) { diff --git a/src/Platform.elm b/src/Platform.elm index 567c6f56..ed37f0a1 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -40,7 +40,7 @@ import Json.Decode exposing (Decoder) import Json.Encode as Encode import List exposing ((::)) import Maybe exposing (Maybe(..)) -import Platform.Bag as Bag +import Platform.Raw.Sub as RawSub import Platform.Cmd exposing (Cmd) import Platform.Raw.Channel as Channel import Platform.Raw.Scheduler as RawScheduler @@ -206,8 +206,8 @@ have command and/or subscriptions to process. Each command is a `Platform.Task Never (Maybe msg)`. If the Task resolves with `Just something` we must send that `something` to the app. -Each sub is a tuple `( IncomingPortId, HiddenConvertedSubType -> msg )` we can -collect these id's and functions and pass them to `resetSubscriptions`. +Each sub is a tuple `( RawSub.Id, RawSub.HiddenConvertedSubType -> msg )` we +can collect these id's and functions and pass them to `resetSubscriptions`. -} setupEffectsChannel : SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) @@ -350,14 +350,6 @@ type UpdateMetadata | AsyncUpdate -type IncomingPortId - = IncomingPortId IncomingPortId - - -type HiddenConvertedSubType - = HiddenConvertedSubType HiddenConvertedSubType - - type ReceivedData appMsg selfMsg = Self selfMsg | App (AppMsgPayload appMsg) @@ -416,46 +408,16 @@ makeProgram = Elm.Kernel.Basics.fudgeType -effectManagerNameToString : Bag.EffectManagerName -> String -effectManagerNameToString = - Elm.Kernel.Platform.effectManagerNameToString - - unwrapCmd : Cmd a -> List (Task Never (Maybe msg)) unwrapCmd = Elm.Kernel.Basics.unwrapTypeWrapper -unwrapSub : Sub a -> List ( IncomingPortId, HiddenConvertedSubType -> msg ) +unwrapSub : Sub a -> List ( RawSub.Id, RawSub.HiddenConvertedSubType -> msg ) unwrapSub = Elm.Kernel.Basics.unwrapTypeWrapper -createHiddenMyCmdList : List (Bag.LeafType msg) -> List (HiddenMyCmd msg) -createHiddenMyCmdList = - Elm.Kernel.Basics.fudgeType - - -createHiddenMySubList : List (Bag.LeafType msg) -> List (HiddenMySub msg) -createHiddenMySubList = - Elm.Kernel.Basics.fudgeType - - -createIncomingPortConverters : List (HiddenMySub msg) -> List (Encode.Value -> msg) -createIncomingPortConverters = - Elm.Kernel.Basics.fudgeType - - -createPlatformEffectFuncsFromCmd : HiddenMyCmd msg -> Task Never (Maybe msg) -createPlatformEffectFuncsFromCmd = - Elm.Kernel.Basics.fudgeType - - -createPlatformEffectFuncsFromSub : HiddenMySub msg -> ( IncomingPortId, HiddenConvertedSubType -> msg ) -createPlatformEffectFuncsFromSub = - Elm.Kernel.Basics.fudgeType - - -resetSubscriptions : List ( IncomingPortId, HiddenConvertedSubType -> () ) -> ImpureFunction +resetSubscriptions : List ( RawSub.Id, RawSub.HiddenConvertedSubType -> () ) -> ImpureFunction resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions diff --git a/src/Platform/Bag.elm b/src/Platform/Bag.elm deleted file mode 100644 index e88fcc93..00000000 --- a/src/Platform/Bag.elm +++ /dev/null @@ -1,24 +0,0 @@ -module Platform.Bag exposing - ( EffectBag - , EffectManagerName - , LeafType - ) - - -type alias EffectBag msg = - List - { home : EffectManagerName - , value : LeafType msg - } - - -type LeafType msg - = LeafType Kernel - - -type EffectManagerName - = EffectManagerName Kernel - - -type Kernel - = Kernel Kernel diff --git a/src/Platform/Cmd.elm b/src/Platform/Cmd.elm index 8db19a0a..c07fcb86 100644 --- a/src/Platform/Cmd.elm +++ b/src/Platform/Cmd.elm @@ -31,7 +31,6 @@ import Elm.Kernel.Basics import Elm.Kernel.Platform import List import Maybe exposing (Maybe) -import Platform.Bag as Bag import Platform.Raw.Task as RawTask import Result exposing (Result) diff --git a/src/Platform/Raw/Sub.elm b/src/Platform/Raw/Sub.elm new file mode 100644 index 00000000..2a5bbc08 --- /dev/null +++ b/src/Platform/Raw/Sub.elm @@ -0,0 +1,16 @@ +module Platform.Raw.Sub exposing + ( RawSub + , Id + , HiddenConvertedSubType + ) + + +type alias RawSub msg = + List ( Id, HiddenConvertedSubType -> msg ) + +type Id + = Id Id + + +type HiddenConvertedSubType + = HiddenConvertedSubType HiddenConvertedSubType diff --git a/src/Platform/Sub.elm b/src/Platform/Sub.elm index 0ee828e1..e877d990 100644 --- a/src/Platform/Sub.elm +++ b/src/Platform/Sub.elm @@ -28,7 +28,7 @@ module Platform.Sub exposing import Basics exposing (..) import List -import Platform.Bag as Bag +import Platform.Raw.Sub as RawSub @@ -53,7 +53,7 @@ into a real application! -} type Sub msg - = Sub (List ( SubId, HiddenConvertedSubType -> msg )) + = Sub (RawSub.RawSub msg) {-| Tell the runtime that there are no subscriptions. @@ -97,14 +97,6 @@ map fn (Sub data) = |> Sub -type SubId - = SubId SubId - - -type HiddenConvertedSubType - = HiddenConvertedSubType HiddenConvertedSubType - - -getSubMapper : (a -> msg) -> ( SubId, HiddenConvertedSubType -> a ) -> ( SubId, HiddenConvertedSubType -> msg ) +getSubMapper : (a -> msg) -> ( RawSub.Id, RawSub.HiddenConvertedSubType -> a ) -> ( RawSub.Id, RawSub.HiddenConvertedSubType -> msg ) getSubMapper fn ( id, tagger ) = ( id, \hcst -> fn (tagger hcst) ) diff --git a/src/Time.elm b/src/Time.elm index 955dc4d9..2d2e601a 100644 --- a/src/Time.elm +++ b/src/Time.elm @@ -43,6 +43,7 @@ import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform import Platform.Raw.Channel as Channel +import Platform.Raw.Sub as RawSub import Platform.Sub exposing (Sub) import Process import String exposing (String) @@ -567,16 +568,12 @@ every interval tagger = subscription (setInterval interval) (\f -> tagger (millisToPosix (round f))) -type SubId - = SubId SubId - - -setInterval : Float -> SubId +setInterval : Float -> RawSub.Id setInterval = Elm.Kernel.Time.setInterval -subscription : SubId -> (Float -> msg) -> Sub msg +subscription : RawSub.Id -> (Float -> msg) -> Sub msg subscription = Elm.Kernel.Platform.subscription From 90b631b7101c34635d09115c5d8cfb133b11e5d1 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 11:36:27 +0100 Subject: [PATCH 157/170] wip impure functions --- NEWS | 29 +++++++++ src/Elm/Kernel/Platform.js | 4 +- src/Platform.elm | 29 +++------ src/Platform/Raw/Impure.elm | 107 +++++++++++++++++++++++++++++++++ src/Platform/Raw/Scheduler.elm | 68 ++++++++++++--------- src/Platform/Raw/Sub.elm | 5 +- src/Platform/Raw/Task.elm | 34 +++++++---- 7 files changed, 208 insertions(+), 68 deletions(-) create mode 100644 NEWS create mode 100644 src/Platform/Raw/Impure.elm diff --git a/NEWS b/NEWS new file mode 100644 index 00000000..b2177f01 --- /dev/null +++ b/NEWS @@ -0,0 +1,29 @@ +# NEWS + +A little inline blog documenting the development of this library. + +# 2020/4/26 -- A new internal module `Platform.Raw.Impure` + +This module contains an abstaction for functions that **do things** when +they are run. The functions in this module are constrained to take one argument +and return the unit tuple. + +Why can we not use Task's for this, given that this is _exactly_ what they are +intended for. Well, two reasons + +1. Sometimes we need a guarantee that the function will be run exactly when we + need to run. Task are always enqueued; they are only run after stepping + through all the previous Tasks in the queue. Sometimes, this is not + acceptable, for instance when updating the listeners for a subscription + effect. + +2. We need to use impure functions to run Tasks. The + `Platform.Raw.Scheduler.enqueue` function takes a Task, adds it to the + scheduler queue and, if the scheduler is not currently stepping tasks (i.e. + this is not a reentrant call to `Platform.Raw.Scheduler.enqueue`), starts + stepping. This function is impure. However, if we represented it as a Task + we would have an infinite loop! + +Hopefully, use of this module can be reduced to a couple of key places and +maybe even inlined into the scheduler is that is the only place that uses it. +Hopefully, it will help us move all effectful functions out of elm. diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 48509238..e23d0f85 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -215,14 +215,14 @@ let _Platform_subscriptionProcessIds = 0; const _Platform_createSubProcess = (onSubUpdate) => { const channel = __Channel_rawUnbounded(); const key = { id: _Platform_subscriptionProcessIds++ }; - const msgHandler = (msg) => + const msgHandler = (hcst) => __RawTask_execImpure((_) => { const subscriptionState = _Platform_subscriptionStates.get(key); if (__Basics_isDebug && subscriptionState === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); } for (const sendToApp of subscriptionState.__$listeners) { - sendToApp(msg); + __RawScheduler_rawSpawn(sendToApp(hcst)); } return __Utils_Tuple0; }); diff --git a/src/Platform.elm b/src/Platform.elm index ed37f0a1..4512ee6c 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -40,10 +40,11 @@ import Json.Decode exposing (Decoder) import Json.Encode as Encode import List exposing ((::)) import Maybe exposing (Maybe(..)) -import Platform.Raw.Sub as RawSub import Platform.Cmd exposing (Cmd) import Platform.Raw.Channel as Channel +import Platform.Raw.Impure as Impure import Platform.Raw.Scheduler as RawScheduler +import Platform.Raw.Sub as RawSub import Platform.Raw.Task as RawTask import Platform.Sub exposing (Sub) import Result exposing (Result(..)) @@ -270,7 +271,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Channel.Sender (AppMsgPayload appMsg) - -> ( SendToApp appMsg -> (), RawTask.Task () ) + -> ( Impure.Function (SendToApp appMsg), RawTask.Task () ) dispatchEffects cmdBag subBag = let cmds = @@ -281,14 +282,14 @@ dispatchEffects cmdBag subBag = in \channel -> let - updateSubs sendToAppFunc = + updateSubs = let -- Reset and re-register all subscriptions. - (ImpureFunction ip) = + (Impure.Function ip) = subs |> List.map (\( id, tagger ) -> - ( id, \v -> sendToAppFunc (tagger v) AsyncUpdate ) + ( id, \v -> RawTask.Value (sendToAppFunc (tagger v) AsyncUpdate) ) ) |> resetSubscriptions in @@ -320,18 +321,6 @@ wrapTask task = Task (RawTask.map Ok task) -impureAndThen : ImpureFunction -> ImpureFunction -> ImpureFunction -impureAndThen (ImpureFunction ip1) (ImpureFunction ip2) = - ImpureFunction - (\() -> - let - () = - ip1 () - in - ip2 () - ) - - type alias SendToApp msg = msg -> UpdateMetadata -> () @@ -359,10 +348,6 @@ type alias AppMsgPayload appMsg = List (Task Never (Maybe appMsg)) -type ImpureFunction - = ImpureFunction (() -> ()) - - type HiddenMyCmd msg = HiddenMyCmd (HiddenMyCmd msg) @@ -418,6 +403,6 @@ unwrapSub = Elm.Kernel.Basics.unwrapTypeWrapper -resetSubscriptions : List ( RawSub.Id, RawSub.HiddenConvertedSubType -> () ) -> ImpureFunction +resetSubscriptions : List ( RawSub.Id, RawSub.HiddenConvertedSubType -> RawTask.Task () ) -> Impure.Function () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions diff --git a/src/Platform/Raw/Impure.elm b/src/Platform/Raw/Impure.elm new file mode 100644 index 00000000..12ba00f7 --- /dev/null +++ b/src/Platform/Raw/Impure.elm @@ -0,0 +1,107 @@ +module Platform.Raw.Impure exposing (Function, Function2, Function3, andThen, function,map, run, unwrapFunction, xx2, xx42, toThunk) + +{-| This module contains an abstaction for functions that **do things** when +they are run. The functions in this module are constrained to take one argument. + +Why can we not use Task's for this, given that this is _exactly_ what they are +intended for. Well, two reasons + +1. Sometimes we need a guarantee that the function will be run exactly when we + need to run. Task are always enqueued; they are only run after stepping + through all the previous Tasks in the queue. Sometimes, this is not + acceptable, for instance when updating the listeners for a subscription + effect. + +2. We need to use impure functions to run Tasks. The + `Platform.Raw.Scheduler.enqueue` function takes a Task, adds it to the + scheduler queue and, if the scheduler is not currently stepping tasks (i.e. + this is not a reentrant call to `Platform.Raw.Scheduler.enqueue`), starts + stepping. This function is impure. However, if we represented it as a Task + we would have an infinite loop! + +Hopefully, use of this module can be reduced to a couple of key places and +maybe even inlined into the scheduler is that is the only place that uses it. +Hopefully, it will help us move all effectful functions out of elm. + +-} + +import Basics exposing ((|>)) +import Elm.Kernel.Basics + + +{-| Is actually just a function. We type fudge so that js can treat impure +functions identically to normal functions. +-} +type Function a b + = Function + + +type alias Function2 a b c = + Function a (Function b c) + + +type alias Function3 a b c d = + Function2 a b (Function c d) + + +function : (a -> b) -> Function a b +function = + Elm.Kernel.Basics.fudgeType + + +andThen : Function b c -> Function a b -> Function a c +andThen ip2 ip1 = + function + (\a -> + let + b = + unwrapFunction ip1 a + in + unwrapFunction ip2 b + ) + +map : (b -> c) -> Function a b -> Function a c +map mapper ip = + function + (\a -> + let + b = + unwrapFunction ip a + in + mapper b + ) + + +unwrapFunction : Function a b -> (a -> b) +unwrapFunction = + Elm.Kernel.Basics.fudgeType + + +run : a -> Function a b -> b +run x f = + unwrapFunction f x + + +xx2 : Function a b -> (c -> a) -> Function c b +xx2 f g = + function + (\x -> + unwrapFunction + f + (g x) + ) + + +xx42 : (a -> Function () b) -> Function a b +xx42 f = + function + (\x -> + unwrapFunction + (f x) + () + ) + +toThunk : a -> Function a b -> Function () b +toThunk x f = + function (\() -> x) + |> andThen f diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index 466608cc..5651bbab 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -9,6 +9,7 @@ import Debug import Elm.Kernel.Scheduler import List import Maybe exposing (Maybe(..)) +import Platform.Raw.Impure as Impure import Platform.Raw.Task as RawTask @@ -30,18 +31,17 @@ type UniqueId Will create, register and **enqueue** a new process. -} -rawSpawn : RawTask.Task a -> ProcessId -rawSpawn initTask = - enqueue - (ProcessId { id = getGuid () }) - initTask +rawSpawn : Impure.Function (RawTask.Task a) ProcessId +rawSpawn = + enqueue (ProcessId { id = getGuid () }) {-| Create a task that spawns a processes. -} spawn : RawTask.Task a -> RawTask.Task ProcessId spawn task = - RawTask.execImpure (\() -> rawSpawn task) + RawTask.execImpure + (Impure.toThunk task rawSpawn) {-| Create a task kills a process. @@ -54,7 +54,8 @@ receive values. -} kill : ProcessId -> RawTask.Task () kill processId = - RawTask.execImpure (\() -> rawKill processId) + RawTask.execImpure + (Impure.toThunk processId rawKill) batch : List ProcessId -> RawTask.Task ProcessId @@ -62,15 +63,17 @@ batch ids = spawn (RawTask.AsyncAction (\doneCallback -> - let - () = - doneCallback (spawn (RawTask.Value ())) - in - \() -> - List.foldr - (\id () -> rawKill id) - () - ids + -- let + -- () = + -- doneCallback (spawn (RawTask.Value ())) + -- in + List.foldr + (\id ip -> + ip + |> Impure.andThen (Impure.toThunk id rawKill) + ) + (Impure.function (\() -> ())) + ids ) ) @@ -82,7 +85,7 @@ call, drain the run queue but stepping all processes. Returns the enqueued `Process`. -} -enqueue : ProcessId -> RawTask.Task state -> ProcessId +enqueue : ProcessId -> Impure.Function (RawTask.Task state) ProcessId enqueue = enqueueWithStepper stepper @@ -118,17 +121,21 @@ stepper processId root = {-| NON PURE! -} -rawKill : ProcessId -> () -rawKill id = - case getProcessState id of - Just (Running killer) -> - killer () - - Just (Ready _) -> - () - - Nothing -> - () +rawKill : Impure.Function ProcessId () +rawKill = + Impure.xx42 + (\id -> + (case getProcessState id of + Just (Running killer) -> + killer + + Just (Ready _) -> + Impure.function (\() -> ()) + + Nothing -> + Impure.function (\() -> ()) + ) + ) @@ -145,6 +152,9 @@ getProcessState = Elm.Kernel.Scheduler.getProcessState -enqueueWithStepper : (ProcessId -> RawTask.Task state -> ProcessState state) -> ProcessId -> RawTask.Task state -> ProcessId +enqueueWithStepper : + (ProcessId -> RawTask.Task state -> ProcessState state) + -> ProcessId + -> Impure.Function (RawTask.Task state) ProcessId enqueueWithStepper = Elm.Kernel.Scheduler.enqueueWithStepper diff --git a/src/Platform/Raw/Sub.elm b/src/Platform/Raw/Sub.elm index 2a5bbc08..44cea965 100644 --- a/src/Platform/Raw/Sub.elm +++ b/src/Platform/Raw/Sub.elm @@ -1,13 +1,14 @@ module Platform.Raw.Sub exposing - ( RawSub + ( HiddenConvertedSubType , Id - , HiddenConvertedSubType + , RawSub ) type alias RawSub msg = List ( Id, HiddenConvertedSubType -> msg ) + type Id = Id Id diff --git a/src/Platform/Raw/Task.elm b/src/Platform/Raw/Task.elm index ad7fb98d..6f1b265b 100644 --- a/src/Platform/Raw/Task.elm +++ b/src/Platform/Raw/Task.elm @@ -9,19 +9,20 @@ import Basics exposing (..) import Debug import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) +import Platform.Raw.Impure as Impure type Task val = Value val - | AsyncAction (DoneCallback val -> TryAbortAction) + | AsyncAction (Impure.Function (DoneCallback val) TryAbortAction) type alias DoneCallback val = - Task val -> () + Impure.Function (Task val) () type alias TryAbortAction = - () -> () + Impure.Function () () andThen : (a -> Task b) -> Task a -> Task b @@ -32,23 +33,30 @@ andThen func task = AsyncAction doEffect -> AsyncAction - (\doneCallback -> + (Impure.xx2 doEffect - (\newTask -> doneCallback (andThen func newTask)) + (\doneCallback -> Impure.xx2 doneCallback (andThen func)) ) {-| Create a task that executes a non pure function -} -execImpure : (() -> a) -> Task a +execImpure : Impure.Function () a -> Task a execImpure func = AsyncAction - (\doneCallback -> - let - () = - doneCallback (Value (func ())) - in - \() -> () + (Impure.xx42 + (\doneCallback -> + Impure.function + (\() -> + let + () = + func + |> Impure.map Value + |> Impure.andThen doneCallback + in + Impure.function (\() -> ()) + ) + ) ) @@ -64,6 +72,6 @@ sleep time = AsyncAction (delay time (Value ())) -delay : Float -> Task val -> DoneCallback val -> TryAbortAction +delay : Float -> Task val -> Impure.Function (DoneCallback val) TryAbortAction delay = Elm.Kernel.Scheduler.delay From 8864a940ab1ca5aabce81f9cc8626f0f2121da1c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 12:28:24 +0100 Subject: [PATCH 158/170] swap DoneCallback for Future --- NEWS | 13 +++++++++++++ src/Elm/Kernel/Scheduler.js | 28 +++++++++++++++------------ src/Platform.elm | 2 +- src/Platform/Raw/Channel.elm | 7 ++++--- src/Platform/Raw/Scheduler.elm | 25 ++++++++++++------------ src/Platform/Raw/Sub.elm | 5 +++-- src/Platform/Raw/Task.elm | 35 +++++++++++++++++----------------- src/Platform/Scheduler.elm | 27 +++++++++++++------------- 8 files changed, 82 insertions(+), 60 deletions(-) create mode 100644 NEWS diff --git a/NEWS b/NEWS new file mode 100644 index 00000000..644c2afb --- /dev/null +++ b/NEWS @@ -0,0 +1,13 @@ +# NEWS + +A sort of inline blog for updates about this core libary + +## 2020/04/26 - the future? + +I wan't to move to away from callbacks and towards async/await and promises (or +futures). Firstly, I find that async/await is much easier to reason about than +callbacks and leads to much prettier code. Also, in the back of my mind is the +desire to eventually port the core libraries to rust for native compiled elm +code. + +Todays change is just cosmetic, but hopefully is step 1. diff --git a/src/Elm/Kernel/Scheduler.js b/src/Elm/Kernel/Scheduler.js index defcceb5..48417421 100644 --- a/src/Elm/Kernel/Scheduler.js +++ b/src/Elm/Kernel/Scheduler.js @@ -24,8 +24,8 @@ function _Scheduler_succeed(value) { return __NiceScheduler_succeed(value); } -function _Scheduler_binding(callback) { - return __NiceScheduler_binding(callback); +function _Scheduler_binding(future) { + return __NiceScheduler_binding(future); } function _Scheduler_rawSpawn(task) { @@ -90,13 +90,17 @@ const _Scheduler_enqueueWithStepper = (stepper) => { }; }; -var _Scheduler_delay = F3(function (time, value, callback) { - var id = setTimeout(function () { - callback(value); - }, time); - - return function (x) { - clearTimeout(id); - return x; - }; -}); +const _Scheduler_delay = F2((time, value) => ({ + __$then_: (callback) => { + let id = setTimeout(() => { + callback(value); + }, time); + return (x) => { + if (id !== null) { + clearTimeout(id); + id = null; + } + return x; + }; + }, +})); diff --git a/src/Platform.elm b/src/Platform.elm index ed37f0a1..08b2db74 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -40,10 +40,10 @@ import Json.Decode exposing (Decoder) import Json.Encode as Encode import List exposing ((::)) import Maybe exposing (Maybe(..)) -import Platform.Raw.Sub as RawSub import Platform.Cmd exposing (Cmd) import Platform.Raw.Channel as Channel import Platform.Raw.Scheduler as RawScheduler +import Platform.Raw.Sub as RawSub import Platform.Raw.Task as RawTask import Platform.Sub exposing (Sub) import Result exposing (Result(..)) diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index d86b185b..f73a5ff2 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -25,9 +25,10 @@ type alias Channel msg = recv : (msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a recv tagger chl = RawTask.AsyncAction - (\doneCallback -> - rawRecv chl (\msg -> doneCallback (tagger msg)) - ) + { then_ = + \doneCallback -> + rawRecv chl (\msg -> doneCallback (tagger msg)) + } tryRecv : (Maybe msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index 466608cc..c4b8837b 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -61,17 +61,18 @@ batch : List ProcessId -> RawTask.Task ProcessId batch ids = spawn (RawTask.AsyncAction - (\doneCallback -> - let - () = - doneCallback (spawn (RawTask.Value ())) - in - \() -> - List.foldr - (\id () -> rawKill id) - () - ids - ) + { then_ = + \doneCallback -> + let + () = + doneCallback (spawn (RawTask.Value ())) + in + \() -> + List.foldr + (\id () -> rawKill id) + () + ids + } ) @@ -105,7 +106,7 @@ stepper processId root = RawTask.AsyncAction doEffect -> Running - (doEffect + (doEffect.then_ (\newRoot -> let (ProcessId _) = diff --git a/src/Platform/Raw/Sub.elm b/src/Platform/Raw/Sub.elm index 2a5bbc08..44cea965 100644 --- a/src/Platform/Raw/Sub.elm +++ b/src/Platform/Raw/Sub.elm @@ -1,13 +1,14 @@ module Platform.Raw.Sub exposing - ( RawSub + ( HiddenConvertedSubType , Id - , HiddenConvertedSubType + , RawSub ) type alias RawSub msg = List ( Id, HiddenConvertedSubType -> msg ) + type Id = Id Id diff --git a/src/Platform/Raw/Task.elm b/src/Platform/Raw/Task.elm index ad7fb98d..fd788b1c 100644 --- a/src/Platform/Raw/Task.elm +++ b/src/Platform/Raw/Task.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Task exposing (DoneCallback, Task(..), TryAbortAction, andThen, execImpure, map, sleep) +module Platform.Raw.Task exposing (Future, Task(..), TryAbortAction, andThen, execImpure, map, sleep) {-| This module contains the low level logic for tasks. A `Task` is a sequence of actions (either syncronous or asyncronous) that will be @@ -13,11 +13,11 @@ import Maybe exposing (Maybe(..)) type Task val = Value val - | AsyncAction (DoneCallback val -> TryAbortAction) + | AsyncAction (Future val) -type alias DoneCallback val = - Task val -> () +type alias Future a = + { then_ : (Task a -> ()) -> TryAbortAction } type alias TryAbortAction = @@ -30,12 +30,12 @@ andThen func task = Value val -> func val - AsyncAction doEffect -> + AsyncAction fut -> AsyncAction - (\doneCallback -> - doEffect - (\newTask -> doneCallback (andThen func newTask)) - ) + { then_ = + \callback -> + fut.then_ (\newTask -> callback (andThen func newTask)) + } {-| Create a task that executes a non pure function @@ -43,13 +43,14 @@ andThen func task = execImpure : (() -> a) -> Task a execImpure func = AsyncAction - (\doneCallback -> - let - () = - doneCallback (Value (func ())) - in - \() -> () - ) + { then_ = + \callback -> + let + () = + callback (Value (func ())) + in + \() -> () + } map : (a -> b) -> Task a -> Task b @@ -64,6 +65,6 @@ sleep time = AsyncAction (delay time (Value ())) -delay : Float -> Task val -> DoneCallback val -> TryAbortAction +delay : Float -> Task val -> Future val delay = Elm.Kernel.Scheduler.delay diff --git a/src/Platform/Scheduler.elm b/src/Platform/Scheduler.elm index 0c457ea9..33282ae3 100644 --- a/src/Platform/Scheduler.elm +++ b/src/Platform/Scheduler.elm @@ -1,4 +1,4 @@ -module Platform.Scheduler exposing (DoneCallback, ProcessId, TryAbortAction, andThen, binding, fail, kill, map, onError, rawSpawn, sleep, spawn, succeed, unwrapTask, wrapTask) +module Platform.Scheduler exposing (ProcessId, TryAbortAction, andThen, binding, fail, kill, map, onError, rawSpawn, sleep, spawn, succeed, unwrapTask, wrapTask) {-| The definition of the `Task` and `ProcessId` really belong in the `Platform.RawScheduler` module for two reasons. @@ -55,8 +55,8 @@ type alias ProcessId = RawScheduler.ProcessId -type alias DoneCallback err ok = - Platform.Task err ok -> () +type alias Future err ok = + { then_ : (Platform.Task err ok -> ()) -> TryAbortAction } type alias TryAbortAction = @@ -73,11 +73,11 @@ fail e = wrapTask (RawTask.Value (Err e)) -binding : (DoneCallback err ok -> TryAbortAction) -> Platform.Task err ok -binding callback = +binding : Future err ok -> Platform.Task err ok +binding fut = wrapTask (RawTask.AsyncAction - (\doneCallback -> callback (taskFn (\task -> doneCallback task))) + { then_ = \doneCallback -> fut.then_ (taskFn (\task -> doneCallback task)) } ) @@ -86,13 +86,14 @@ binding callback = execImpure : (() -> a) -> Platform.Task Never a execImpure func = binding - (\doneCallback -> - let - () = - doneCallback (succeed (func ())) - in - \() -> () - ) + { then_ = + \doneCallback -> + let + () = + doneCallback (succeed (func ())) + in + \() -> () + } andThen : (ok1 -> Platform.Task err ok2) -> Platform.Task err ok1 -> Platform.Task err ok2 From 1af9eef9782dfaa7f60214070481a73a2a909132 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 17:12:27 +0100 Subject: [PATCH 159/170] add impure abstraction --- NEWS | 29 ++++++++++- src/Elm/Kernel/Platform.js | 41 +++++++-------- src/Elm/Kernel/Time.js | 2 +- src/Platform.elm | 34 ++++-------- src/Platform/Raw/Impure.elm | 101 ++++++++++++++++++++++++++++++++++++ 5 files changed, 159 insertions(+), 48 deletions(-) create mode 100644 src/Platform/Raw/Impure.elm diff --git a/NEWS b/NEWS index 644c2afb..dd4258ef 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,33 @@ # NEWS -A sort of inline blog for updates about this core libary +A little inline blog documenting the development of this library. + +# 2020/4/26 -- A new internal module `Platform.Raw.Impure` + +This module contains an abstaction for functions that **do things** when +they are run. The functions in this module are constrained to take one argument +and return the unit tuple. + +Why can we not use Task's for this, given that this is _exactly_ what they are +intended for. Well, two reasons + +1. Sometimes we need a guarantee that the function will be run exactly when we + need to run. Task are always enqueued; they are only run after stepping + through all the previous Tasks in the queue. Sometimes, this is not + acceptable, for instance when updating the listeners for a subscription + effect. + +2. We need to use impure functions to run Tasks. The + `Platform.Raw.Scheduler.enqueue` function takes a Task, adds it to the + scheduler queue and, if the scheduler is not currently stepping tasks (i.e. + this is not a reentrant call to `Platform.Raw.Scheduler.enqueue`), starts + stepping. This function is impure. However, if we represented it as a Task + we would have an infinite loop! + +Hopefully, use of this module can be reduced to a couple of key places and +maybe even inlined into the scheduler is that is the only place that uses it. +Hopefully, it will help us move all effectful functions out of elm. + ## 2020/04/26 - the future? diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index 48509238..dd884c98 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -8,7 +8,7 @@ import Elm.Kernel.Channel exposing (rawUnbounded, rawSend) import Elm.Kernel.Basics exposing (isDebug) import Result exposing (isOk) import Maybe exposing (Nothing) -import Platform exposing (Task, ProcessId, initializeHelperFunctions, ImpureFunction) +import Platform exposing (Task, ProcessId, initializeHelperFunctions) import Platform.Raw.Scheduler as RawScheduler exposing (rawSpawn) import Platform.Raw.Task as RawTask exposing (execImpure, andThen) import Platform.Raw.Channel as RawChannel exposing (recv) @@ -215,14 +215,14 @@ let _Platform_subscriptionProcessIds = 0; const _Platform_createSubProcess = (onSubUpdate) => { const channel = __Channel_rawUnbounded(); const key = { id: _Platform_subscriptionProcessIds++ }; - const msgHandler = (msg) => + const msgHandler = (hcst) => __RawTask_execImpure((_) => { const subscriptionState = _Platform_subscriptionStates.get(key); if (__Basics_isDebug && subscriptionState === undefined) { __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); } for (const sendToApp of subscriptionState.__$listeners) { - sendToApp(msg); + sendToApp(hcst); } return __Utils_Tuple0; }); @@ -239,25 +239,24 @@ const _Platform_createSubProcess = (onSubUpdate) => { return __Utils_Tuple2(key, channel.a); }; -const _Platform_resetSubscriptions = (newSubs) => - __Platform_ImpureFunction((_) => { - for (const subState of _Platform_subscriptionStates.values()) { - subState.__$listeners.length = 0; - } - for (const tuple of __List_toArray(newSubs)) { - const key = tuple.a; - const sendToApp = tuple.b; - const subState = _Platform_subscriptionStates.get(key); - if (__Basics_isDebug && subState.__$listeners === undefined) { - __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); - } - subState.__$listeners.push(sendToApp); - } - for (const subState of _Platform_subscriptionStates.values()) { - subState.__$onSubUpdate(subState.__$listeners.length); +const _Platform_resetSubscriptions = (newSubs) => (_) => { + for (const subState of _Platform_subscriptionStates.values()) { + subState.__$listeners.length = 0; + } + for (const tuple of __List_toArray(newSubs)) { + const key = tuple.a; + const sendToApp = tuple.b; + const subState = _Platform_subscriptionStates.get(key); + if (__Basics_isDebug && subState.__$listeners === undefined) { + __Debug_crash(12, __Debug_runtimeCrashReason("subscriptionProcessMissing"), key && key.id); } - return __Utils_Tuple0; - }); + subState.__$listeners.push(sendToApp); + } + for (const subState of _Platform_subscriptionStates.values()) { + subState.__$onSubUpdate(subState.__$listeners.length); + } + return __Utils_Tuple0; +}; const _Platform_effectManagerNameToString = (name) => name; diff --git a/src/Elm/Kernel/Time.js b/src/Elm/Kernel/Time.js index a8edc20d..dd10931e 100644 --- a/src/Elm/Kernel/Time.js +++ b/src/Elm/Kernel/Time.js @@ -3,7 +3,7 @@ import Time exposing (customZone, Name) import Elm.Kernel.List exposing (Nil) import Elm.Kernel.Platform exposing (createSubProcess) -import Elm.Kernel.Scheduler exposing (execImpure) +import Platform.Scheduler as Scheduler exposing (execImpure) import Elm.Kernel.Channel exposing (rawSend) import Elm.Kernel.Utils exposing (Tuple0) diff --git a/src/Platform.elm b/src/Platform.elm index 08b2db74..63a6b46f 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -42,6 +42,7 @@ import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform.Cmd exposing (Cmd) import Platform.Raw.Channel as Channel +import Platform.Raw.Impure as Impure import Platform.Raw.Scheduler as RawScheduler import Platform.Raw.Sub as RawSub import Platform.Raw.Task as RawTask @@ -66,7 +67,7 @@ type alias InitializeHelperFunctions model appMsg = Cmd appMsg -> Sub appMsg -> Channel.Sender (AppMsgPayload appMsg) - -> ( SendToApp appMsg -> (), RawTask.Task () ) + -> ( Impure.Function (SendToApp appMsg) (), RawTask.Task () ) } @@ -270,7 +271,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Channel.Sender (AppMsgPayload appMsg) - -> ( SendToApp appMsg -> (), RawTask.Task () ) + -> ( Impure.Function (SendToApp appMsg) (), RawTask.Task () ) dispatchEffects cmdBag subBag = let cmds = @@ -281,18 +282,17 @@ dispatchEffects cmdBag subBag = in \channel -> let - updateSubs sendToAppFunc = - let - -- Reset and re-register all subscriptions. - (ImpureFunction ip) = + updateSubs = + -- Reset and re-register all subscriptions. + Impure.xx42 + (\sendToAppFunc -> subs |> List.map (\( id, tagger ) -> ( id, \v -> sendToAppFunc (tagger v) AsyncUpdate ) ) |> resetSubscriptions - in - ip () + ) in ( updateSubs , Channel.send @@ -320,18 +320,6 @@ wrapTask task = Task (RawTask.map Ok task) -impureAndThen : ImpureFunction -> ImpureFunction -> ImpureFunction -impureAndThen (ImpureFunction ip1) (ImpureFunction ip2) = - ImpureFunction - (\() -> - let - () = - ip1 () - in - ip2 () - ) - - type alias SendToApp msg = msg -> UpdateMetadata -> () @@ -359,10 +347,6 @@ type alias AppMsgPayload appMsg = List (Task Never (Maybe appMsg)) -type ImpureFunction - = ImpureFunction (() -> ()) - - type HiddenMyCmd msg = HiddenMyCmd (HiddenMyCmd msg) @@ -418,6 +402,6 @@ unwrapSub = Elm.Kernel.Basics.unwrapTypeWrapper -resetSubscriptions : List ( RawSub.Id, RawSub.HiddenConvertedSubType -> () ) -> ImpureFunction +resetSubscriptions : List ( RawSub.Id, RawSub.HiddenConvertedSubType -> () ) -> Impure.Function () () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions diff --git a/src/Platform/Raw/Impure.elm b/src/Platform/Raw/Impure.elm new file mode 100644 index 00000000..d5039f4b --- /dev/null +++ b/src/Platform/Raw/Impure.elm @@ -0,0 +1,101 @@ +module Platform.Raw.Impure exposing (Function, andThen, function, map, run, toThunk, unwrapFunction, xx2, xx42) + +{-| This module contains an abstaction for functions that **do things** when +they are run. The functions in this module are constrained to take one argument. + +Why can we not use Task's for this, given that this is _exactly_ what they are +intended for. Well, two reasons + +1. Sometimes we need a guarantee that the function will be run exactly when we + need to run. Task are always enqueued; they are only run after stepping + through all the previous Tasks in the queue. Sometimes, this is not + acceptable, for instance when updating the listeners for a subscription + effect. + +2. We need to use impure functions to run Tasks. The + `Platform.Raw.Scheduler.enqueue` function takes a Task, adds it to the + scheduler queue and, if the scheduler is not currently stepping tasks (i.e. + this is not a reentrant call to `Platform.Raw.Scheduler.enqueue`), starts + stepping. This function is impure. However, if we represented it as a Task + we would have an infinite loop! + +Hopefully, use of this module can be reduced to a couple of key places and +maybe even inlined into the scheduler is that is the only place that uses it. +Hopefully, it will help us move all effectful functions out of elm. + +-} + +import Basics exposing ((|>)) +import Elm.Kernel.Basics + + +{-| Is actually just a function. We type fudge so that js can treat impure +functions identically to normal functions. +-} +type Function a b + = Function + + +function : (a -> b) -> Function a b +function = + Elm.Kernel.Basics.fudgeType + + +andThen : Function b c -> Function a b -> Function a c +andThen ip2 ip1 = + function + (\a -> + let + b = + unwrapFunction ip1 a + in + unwrapFunction ip2 b + ) + + +map : (b -> c) -> Function a b -> Function a c +map mapper ip = + function + (\a -> + let + b = + unwrapFunction ip a + in + mapper b + ) + + +unwrapFunction : Function a b -> (a -> b) +unwrapFunction = + Elm.Kernel.Basics.fudgeType + + +run : a -> Function a b -> b +run x f = + unwrapFunction f x + + +xx2 : Function a b -> (c -> a) -> Function c b +xx2 f g = + function + (\x -> + unwrapFunction + f + (g x) + ) + + +xx42 : (a -> Function () b) -> Function a b +xx42 f = + function + (\x -> + unwrapFunction + (f x) + () + ) + + +toThunk : a -> Function a b -> Function () b +toThunk x f = + function (\() -> x) + |> andThen f From c089790b134a37d89c549dbb569245ca6e815723 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 17:45:52 +0100 Subject: [PATCH 160/170] prettier test code --- tests/check-kernel-imports.js | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/tests/check-kernel-imports.js b/tests/check-kernel-imports.js index c98667e3..1646f6be 100755 --- a/tests/check-kernel-imports.js +++ b/tests/check-kernel-imports.js @@ -95,7 +95,6 @@ async function processElmFile(file, elmDefinitions, kernelCalls) { addDef(elmCustomTypeMatch[1]); } - const kernelCallMatch = line.match(/(Elm\.Kernel\.\w+).\w+/u); if (kernelCallMatch !== null) { const kernelCall = kernelCallMatch[0]; @@ -251,10 +250,10 @@ Options: const elmCallsFromKernel = new Map(); // Add some definitions from elm/json - elmDefinitions.add('Elm.Kernel.Json.run') - elmDefinitions.add('Elm.Kernel.Json.wrap') - elmDefinitions.add('Elm.Kernel.Json.unwrap') - elmDefinitions.add('Elm.Kernel.Json.errorToString') + elmDefinitions.add("Elm.Kernel.Json.run"); + elmDefinitions.add("Elm.Kernel.Json.wrap"); + elmDefinitions.add("Elm.Kernel.Json.unwrap"); + elmDefinitions.add("Elm.Kernel.Json.errorToString"); const allErrors = []; const allWarnings = []; @@ -283,9 +282,7 @@ Options: for (const [call, locations] of elmCallsFromKernel.entries()) { if (!elmDefinitions.has(call) && !kernelDefinitions.has(call)) { for (const location of locations) { - allErrors.push( - `Import of ${call} at ${location.path}:${location.line} missing definition` - ); + allErrors.push(`Import of ${call} at ${location.path}:${location.line} missing definition`); } } } From 7b1fda505e046bd3dd4ff00ac8543d958481033a Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 17:52:36 +0100 Subject: [PATCH 161/170] use the impure function abstraction in more places --- src/Elm/Kernel/Platform.js | 2 +- src/Platform.elm | 34 +++++++++++++++++++++++----------- src/Platform/Raw/Impure.elm | 30 ++++++++++++------------------ 3 files changed, 36 insertions(+), 30 deletions(-) diff --git a/src/Elm/Kernel/Platform.js b/src/Elm/Kernel/Platform.js index dd884c98..267dc8af 100644 --- a/src/Elm/Kernel/Platform.js +++ b/src/Elm/Kernel/Platform.js @@ -239,7 +239,7 @@ const _Platform_createSubProcess = (onSubUpdate) => { return __Utils_Tuple2(key, channel.a); }; -const _Platform_resetSubscriptions = (newSubs) => (_) => { +const _Platform_resetSubscriptions = (newSubs) => { for (const subState of _Platform_subscriptionStates.values()) { subState.__$listeners.length = 0; } diff --git a/src/Platform.elm b/src/Platform.elm index 63a6b46f..32bd0692 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -67,7 +67,7 @@ type alias InitializeHelperFunctions model appMsg = Cmd appMsg -> Sub appMsg -> Channel.Sender (AppMsgPayload appMsg) - -> ( Impure.Function (SendToApp appMsg) (), RawTask.Task () ) + -> ( Impure.Function (ImpureSendToApp appMsg) (), RawTask.Task () ) } @@ -271,7 +271,7 @@ dispatchEffects : Cmd appMsg -> Sub appMsg -> Channel.Sender (AppMsgPayload appMsg) - -> ( Impure.Function (SendToApp appMsg) (), RawTask.Task () ) + -> ( Impure.Function (ImpureSendToApp appMsg) (), RawTask.Task () ) dispatchEffects cmdBag subBag = let cmds = @@ -282,17 +282,25 @@ dispatchEffects cmdBag subBag = in \channel -> let + -- Impure functin that resets and re-registers all subscriptions. updateSubs = - -- Reset and re-register all subscriptions. - Impure.xx42 + Impure.propagate (\sendToAppFunc -> - subs - |> List.map - (\( id, tagger ) -> - ( id, \v -> sendToAppFunc (tagger v) AsyncUpdate ) - ) - |> resetSubscriptions + let + thunks = + List.map + (\( id, tagger ) -> + ( id + , Impure.propagate + (\v -> sendToAppFunc (tagger v)) + AsyncUpdate + ) + ) + subs + in + Impure.toThunk resetSubscriptions thunks ) + () in ( updateSubs , Channel.send @@ -324,6 +332,10 @@ type alias SendToApp msg = msg -> UpdateMetadata -> () +type alias ImpureSendToApp msg = + msg -> Impure.Function UpdateMetadata () + + type alias DebugMetadata = Encode.Value @@ -402,6 +414,6 @@ unwrapSub = Elm.Kernel.Basics.unwrapTypeWrapper -resetSubscriptions : List ( RawSub.Id, RawSub.HiddenConvertedSubType -> () ) -> Impure.Function () () +resetSubscriptions : Impure.Function (List ( RawSub.Id, Impure.Function RawSub.HiddenConvertedSubType () )) () resetSubscriptions = Elm.Kernel.Platform.resetSubscriptions diff --git a/src/Platform/Raw/Impure.elm b/src/Platform/Raw/Impure.elm index d5039f4b..88af1071 100644 --- a/src/Platform/Raw/Impure.elm +++ b/src/Platform/Raw/Impure.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Impure exposing (Function, andThen, function, map, run, toThunk, unwrapFunction, xx2, xx42) +module Platform.Raw.Impure exposing (Function, andThen, function, map, run, toThunk, unwrapFunction, propagate) {-| This module contains an abstaction for functions that **do things** when they are run. The functions in this module are constrained to take one argument. @@ -75,27 +75,21 @@ run x f = unwrapFunction f x -xx2 : Function a b -> (c -> a) -> Function c b -xx2 f g = - function - (\x -> - unwrapFunction - f - (g x) - ) - - -xx42 : (a -> Function () b) -> Function a b -xx42 f = +{-| Given an (pure) function that creates an impure function from some input +and the input that the created impure function needs create a new impure +function. +-} +propagate : (a -> Function b c) -> b -> Function a c +propagate f b = function - (\x -> + (\a -> unwrapFunction - (f x) - () + (f a) + b ) -toThunk : a -> Function a b -> Function () b -toThunk x f = +toThunk : Function a b -> a -> Function () b +toThunk f x = function (\() -> x) |> andThen f From 7dc588501f91a376e30f8c1975cc62ce323f8b4e Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 18:11:21 +0100 Subject: [PATCH 162/170] execImpure now takes impure functions as arguments --- src/Platform.elm | 6 +++--- src/Platform/Raw/Channel.elm | 7 ++++--- src/Platform/Raw/Impure.elm | 2 +- src/Platform/Raw/Scheduler.elm | 5 +++-- src/Platform/Raw/Task.elm | 5 +++-- 5 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 32bd0692..6eb89471 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -168,7 +168,7 @@ the main app and your individual effect manager. -} type Router appMsg selfMsg = Router - { sendToApp : appMsg -> () + { sendToApp : Impure.Function appMsg () , selfSender : selfMsg -> RawTask.Task () } @@ -178,7 +178,7 @@ be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () sendToApp (Router router) msg = - Task (RawTask.execImpure (\() -> Ok (router.sendToApp msg))) + Task (RawTask.execImpure (Impure.propagate (\() -> Impure.map Ok router.sendToApp) msg)) {-| Send the router a message for your effect manager. This message will @@ -236,8 +236,8 @@ setupEffectsChannel sendToApp2 = Err err -> never err + ) ) - ) |> List.map RawScheduler.spawn |> List.foldr (\curr accTask -> diff --git a/src/Platform/Raw/Channel.elm b/src/Platform/Raw/Channel.elm index f73a5ff2..33d845e0 100644 --- a/src/Platform/Raw/Channel.elm +++ b/src/Platform/Raw/Channel.elm @@ -4,6 +4,7 @@ import Basics exposing (..) import Debug import Elm.Kernel.Channel import Maybe exposing (Maybe(..)) +import Platform.Raw.Impure as Impure import Platform.Raw.Scheduler as RawScheduler import Platform.Raw.Task as RawTask import Tuple @@ -35,7 +36,7 @@ tryRecv : (Maybe msg -> RawTask.Task a) -> Receiver msg -> RawTask.Task a tryRecv tagger chl = RawTask.andThen tagger - (RawTask.execImpure (\() -> rawTryRecv chl)) + (RawTask.execImpure (Impure.function (\() -> rawTryRecv chl))) {-| NON PURE! @@ -54,7 +55,7 @@ rawSend = -} send : Sender msg -> msg -> RawTask.Task () send channelId msg = - RawTask.execImpure (\() -> rawSend channelId msg) + RawTask.execImpure (Impure.function (\() -> rawSend channelId msg)) rawUnbounded : () -> ( Sender msg, Receiver msg ) @@ -64,7 +65,7 @@ rawUnbounded = unbounded : RawTask.Task ( Sender msg, Receiver msg ) unbounded = - RawTask.execImpure rawUnbounded + RawTask.execImpure (Impure.function rawUnbounded) rawRecv : Receiver msg -> (msg -> ()) -> RawTask.TryAbortAction diff --git a/src/Platform/Raw/Impure.elm b/src/Platform/Raw/Impure.elm index 88af1071..34a98a83 100644 --- a/src/Platform/Raw/Impure.elm +++ b/src/Platform/Raw/Impure.elm @@ -1,4 +1,4 @@ -module Platform.Raw.Impure exposing (Function, andThen, function, map, run, toThunk, unwrapFunction, propagate) +module Platform.Raw.Impure exposing (Function, andThen, function, map, propagate, run, toThunk, unwrapFunction) {-| This module contains an abstaction for functions that **do things** when they are run. The functions in this module are constrained to take one argument. diff --git a/src/Platform/Raw/Scheduler.elm b/src/Platform/Raw/Scheduler.elm index c4b8837b..ceec73cf 100644 --- a/src/Platform/Raw/Scheduler.elm +++ b/src/Platform/Raw/Scheduler.elm @@ -9,6 +9,7 @@ import Debug import Elm.Kernel.Scheduler import List import Maybe exposing (Maybe(..)) +import Platform.Raw.Impure as Impure import Platform.Raw.Task as RawTask @@ -41,7 +42,7 @@ rawSpawn initTask = -} spawn : RawTask.Task a -> RawTask.Task ProcessId spawn task = - RawTask.execImpure (\() -> rawSpawn task) + RawTask.execImpure (Impure.function (\() -> rawSpawn task)) {-| Create a task kills a process. @@ -54,7 +55,7 @@ receive values. -} kill : ProcessId -> RawTask.Task () kill processId = - RawTask.execImpure (\() -> rawKill processId) + RawTask.execImpure (Impure.function (\() -> rawKill processId)) batch : List ProcessId -> RawTask.Task ProcessId diff --git a/src/Platform/Raw/Task.elm b/src/Platform/Raw/Task.elm index fd788b1c..6e19253b 100644 --- a/src/Platform/Raw/Task.elm +++ b/src/Platform/Raw/Task.elm @@ -9,6 +9,7 @@ import Basics exposing (..) import Debug import Elm.Kernel.Scheduler import Maybe exposing (Maybe(..)) +import Platform.Raw.Impure as Impure type Task val @@ -40,14 +41,14 @@ andThen func task = {-| Create a task that executes a non pure function -} -execImpure : (() -> a) -> Task a +execImpure : Impure.Function () a -> Task a execImpure func = AsyncAction { then_ = \callback -> let () = - callback (Value (func ())) + callback (Value (Impure.unwrapFunction func ())) in \() -> () } From 353f3267bc76232d3753e9b3579076a5e5c230eb Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 18:15:17 +0100 Subject: [PATCH 163/170] use impure functions for sendToApp --- src/Platform.elm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 6eb89471..6bf95ab0 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -60,9 +60,9 @@ import Tuple code in Elm/Kernel/Platform.js. -} type alias InitializeHelperFunctions model appMsg = - { stepperBuilder : SendToApp appMsg -> model -> SendToApp appMsg + { stepperBuilder : ImpureSendToApp appMsg -> model -> ImpureSendToApp appMsg , setupEffectsChannel : - SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) + ImpureSendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) , dispatchEffects : Cmd appMsg -> Sub appMsg @@ -75,7 +75,7 @@ type alias InitializeHelperFunctions model appMsg = -} initializeHelperFunctions : InitializeHelperFunctions model msg initializeHelperFunctions = - { stepperBuilder = \_ _ -> \_ _ -> () + { stepperBuilder = \sta -> \_ -> sta , dispatchEffects = dispatchEffects , setupEffectsChannel = setupEffectsChannel } @@ -211,7 +211,7 @@ Each sub is a tuple `( RawSub.Id, RawSub.HiddenConvertedSubType -> msg )` we can collect these id's and functions and pass them to `resetSubscriptions`. -} -setupEffectsChannel : SendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) +setupEffectsChannel : ImpureSendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) setupEffectsChannel sendToApp2 = let dispatchChannel : Channel.Channel (AppMsgPayload appMsg) @@ -229,15 +229,16 @@ setupEffectsChannel sendToApp2 = (\r -> case r of Ok (Just msg) -> - sendToApp2 msg AsyncUpdate + Impure.unwrapFunction (sendToApp2 msg) AsyncUpdate + Ok Nothing -> () Err err -> never err - ) ) + ) |> List.map RawScheduler.spawn |> List.foldr (\curr accTask -> From 825c794503e028d651ef4eb0edaecab6c5d18b8b Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 18:18:58 +0100 Subject: [PATCH 164/170] stub routers! --- src/Platform.elm | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 6bf95ab0..36d7c00b 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -22,11 +22,10 @@ module Platform exposing ## Effect Manager Helpers -An extremely tiny portion of library authors should ever write effect managers. -Fundamentally, Elm needs maybe 10 of them total. I get that people are smart, -curious, etc. but that is not a substitute for a legitimate reason to make an -effect manager. Do you have an _organic need_ this fills? Or are you just -curious? Public discussions of your explorations should be framed accordingly. +Effect managers are dead (long live the effect managers). Conseqently you can +**never** get access to a Router, and thus never call `sendToApp` or +`sendToSelf`. If you do not believe that you can _really_ never do this, have a +look at the definitions. We keep them around for now to keep `elm diff` happy. @docs Router, sendToApp, sendToSelf @@ -167,18 +166,15 @@ type ProcessId the main app and your individual effect manager. -} type Router appMsg selfMsg - = Router - { sendToApp : Impure.Function appMsg () - , selfSender : selfMsg -> RawTask.Task () - } + = Router Never {-| Send the router a message for the main loop of your app. This message will be handled by the overall `update` function, just like events from `Html`. -} sendToApp : Router msg a -> msg -> Task x () -sendToApp (Router router) msg = - Task (RawTask.execImpure (Impure.propagate (\() -> Impure.map Ok router.sendToApp) msg)) +sendToApp (Router router) = + never router {-| Send the router a message for your effect manager. This message will @@ -189,8 +185,8 @@ As an example, the effect manager for web sockets -} sendToSelf : Router a msg -> msg -> Task x () -sendToSelf (Router router) msg = - wrapTask (router.selfSender msg) +sendToSelf (Router router) = + never router From 092199640d92639e58a3f82abaeed057b917e46c Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 18:20:57 +0100 Subject: [PATCH 165/170] remove a heap of dead code It feels good to lose the crud! --- src/Platform.elm | 44 -------------------------------------------- 1 file changed, 44 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 36d7c00b..28cd329a 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -306,29 +306,6 @@ dispatchEffects cmdBag subBag = ) -unwrapTask : Task Never a -> RawTask.Task a -unwrapTask (Task task) = - RawTask.map - (\res -> - case res of - Ok val -> - val - - Err x -> - never x - ) - task - - -wrapTask : RawTask.Task a -> Task never a -wrapTask task = - Task (RawTask.map Ok task) - - -type alias SendToApp msg = - msg -> UpdateMetadata -> () - - type alias ImpureSendToApp msg = msg -> Impure.Function UpdateMetadata () @@ -347,31 +324,10 @@ type UpdateMetadata | AsyncUpdate -type ReceivedData appMsg selfMsg - = Self selfMsg - | App (AppMsgPayload appMsg) - - type alias AppMsgPayload appMsg = List (Task Never (Maybe appMsg)) -type HiddenMyCmd msg - = HiddenMyCmd (HiddenMyCmd msg) - - -type HiddenMySub msg - = HiddenMySub (HiddenMySub msg) - - -type HiddenSelfMsg - = HiddenSelfMsg HiddenSelfMsg - - -type HiddenState - = HiddenState HiddenState - - type RawJsObject = RawJsObject RawJsObject From 834b00fd6169d07910852fa6ee57711880494088 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 19:46:29 +0100 Subject: [PATCH 166/170] fix stepperBuilder I still have no idea what this does --- src/Platform.elm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 28cd329a..24f256a1 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -59,7 +59,7 @@ import Tuple code in Elm/Kernel/Platform.js. -} type alias InitializeHelperFunctions model appMsg = - { stepperBuilder : ImpureSendToApp appMsg -> model -> ImpureSendToApp appMsg + { stepperBuilder : ImpureSendToApp appMsg -> model -> appMsg -> UpdateMetadata -> () , setupEffectsChannel : ImpureSendToApp appMsg -> Channel.Sender (AppMsgPayload appMsg) , dispatchEffects : @@ -74,7 +74,7 @@ type alias InitializeHelperFunctions model appMsg = -} initializeHelperFunctions : InitializeHelperFunctions model msg initializeHelperFunctions = - { stepperBuilder = \sta -> \_ -> sta + { stepperBuilder = \_ _ -> \_ _ -> () , dispatchEffects = dispatchEffects , setupEffectsChannel = setupEffectsChannel } From 0a0201d11c7696064c76b89ead6d58226e2f6bae Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 19:57:06 +0100 Subject: [PATCH 167/170] add Random module copy without modification from elm/random. Will fix soon. --- custom-core.sh | 6 +- elm.json | 7 +- init-elm-home.sh | 4 +- src/Random.elm | 896 +++++++++++++++++++++++++++++++++++++++++++++++ src/Time.elm | 1 - 5 files changed, 908 insertions(+), 6 deletions(-) create mode 100644 src/Random.elm diff --git a/custom-core.sh b/custom-core.sh index c410b107..8f72454e 100755 --- a/custom-core.sh +++ b/custom-core.sh @@ -23,7 +23,10 @@ if [[ -d "$CORE_VERSIONS_DIR" ]]; then CORE_VERSION=$(ls "$CORE_VERSIONS_DIR") CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" - if [ $CORE_VERSION_COUNT == 1 ] && [[ -f $CORE_PACKAGE_DIR/custom ]] && [[ -d "$ELM_HOME/$ELM_VERSION/packages/elm/time" ]]; then + if [ $CORE_VERSION_COUNT == 1 ] && \ + [[ -f $CORE_PACKAGE_DIR/custom ]] && \ + [[ -d "$ELM_HOME/$ELM_VERSION/packages/elm/time" ]] && \ + [[ -d "$ELM_HOME/$ELM_VERSION/packages/elm/random" ]] ; then printf "REFRESH " else printf "INIT " @@ -38,6 +41,7 @@ CORE_VERSION=$(ls $CORE_VERSIONS_DIR) CORE_PACKAGE_DIR="$CORE_VERSIONS_DIR/$CORE_VERSION" ./stub.py "$ELM_HOME/$ELM_VERSION/packages/elm/time" +./stub.py "$ELM_HOME/$ELM_VERSION/packages/elm/random" rm -rf "$CORE_PACKAGE_DIR" > /dev/null mkdir "$CORE_PACKAGE_DIR" diff --git a/elm.json b/elm.json index 42c75ae8..adeba27a 100644 --- a/elm.json +++ b/elm.json @@ -10,8 +10,7 @@ "String", "Char", "Bitwise", - "Tuple", - "Time" + "Tuple" ], "Collections": [ "List", @@ -31,7 +30,9 @@ "Platform.Sub", "Platform", "Process", - "Task" + "Task", + "Time", + "Random" ] }, "elm-version": "0.19.0 <= v < 0.20.0", diff --git a/init-elm-home.sh b/init-elm-home.sh index ca381539..72646ca5 100755 --- a/init-elm-home.sh +++ b/init-elm-home.sh @@ -13,5 +13,7 @@ cd $(mktemp -d) git clone -q https://github.com/harrysarson/elm-minimal cd elm-minimal -$ELM make src/Main.elm --output /dev/null || true; +yes | $ELM install elm/time +yes | $ELM install elm/random +$ELM make src/Main.elm --output /dev/null || true diff --git a/src/Random.elm b/src/Random.elm new file mode 100644 index 00000000..5c68ccb7 --- /dev/null +++ b/src/Random.elm @@ -0,0 +1,896 @@ +effect module Random where { command = MyCmd } exposing + ( Generator, Seed + , int, float, uniform, weighted, constant + , list, pair + , map, map2, map3, map4, map5 + , andThen, lazy + , minInt, maxInt + , generate + , step, initialSeed, independentSeed + ) + +{-| This library helps you generate pseudo-random values. + +It is an implementation of [Permuted Congruential Generators][pcg] +by M. E. O'Neil. It is not cryptographically secure. + +[extra]: /packages/elm-community/random-extra/latest +[pcg]: http://www.pcg-random.org/ + + +# Generators +@docs Generator, generate + +# Primitives +@docs int, float, uniform, weighted, constant + +# Data Structures +@docs pair, list + +# Mapping +@docs map, map2, map3, map4, map5 + +# Fancy Stuff +@docs andThen, lazy + +# Constants +@docs maxInt, minInt + +# Generate Values Manually +@docs Seed, step, initialSeed, independentSeed + +-} + +import Basics exposing (..) +import Bitwise +import List exposing ((::)) +import Platform +import Platform.Cmd exposing (Cmd) +import Task exposing (Task) +import Time + + + +-- PRIMITIVE GENERATORS + + +{-| Generate 32-bit integers in a given range. + + import Random + + singleDigit : Random.Generator Int + singleDigit = + Random.int 0 9 + + closeToZero : Random.Generator Int + closeToZero = + Random.int -5 5 + + anyInt : Random.Generator Int + anyInt = + Random.int Random.minInt Random.maxInt + +This generator *can* produce values outside of the range [[`minInt`](#minInt), +[`maxInt`](#maxInt)] but sufficient randomness is not guaranteed. +-} +int : Int -> Int -> Generator Int +int a b = + Generator + (\seed0 -> + let + ( lo, hi ) = + if a < b then + ( a, b ) + else + ( b, a ) + + range = + hi - lo + 1 + in + -- fast path for power of 2 + if (Bitwise.and (range - 1) range) == 0 then + ( (Bitwise.shiftRightZfBy 0 (Bitwise.and (range - 1) (peel seed0))) + lo, next seed0 ) + else + let + threshhold = + -- essentially: period % max + Bitwise.shiftRightZfBy 0 (remainderBy range (Bitwise.shiftRightZfBy 0 -range)) + + accountForBias : Seed -> ( Int, Seed ) + accountForBias seed = + let + x = + peel seed + + seedN = + next seed + in + if x < threshhold then + -- in practice this recurses almost never + accountForBias seedN + else + ( remainderBy range x + lo, seedN ) + in + accountForBias seed0 + ) + + +{-| The underlying algorithm works well in a specific range of integers. +It can generate values outside of that range, but they are “not as random”. + +The `maxInt` that works well is `2147483647`. +-} +maxInt : Int +maxInt = + 2147483647 + + +{-| The underlying algorithm works well in a specific range of integers. +It can generate values outside of that range, but they are “not as random”. + +The `minInt` that works well is `-2147483648`. +-} +minInt : Int +minInt = + -2147483648 + + +{-| Generate floats in a given range. + + import Random + + probability : Random.Generator Float + probability = + Random.float 0 1 + +The `probability` generator will produce values between zero and one with +a uniform distribution. Say it produces a value `p`. We can then check if +`p < 0.4` if we want something to happen 40% of the time. + +This becomes very powerful when paired with functions like [`map`](#map) and +[`andThen`](#andThen). Rather than dealing with twenty random float messages +in your `update`, you can build up sophisticated logic in the `Generator` +itself! +-} +float : Float -> Float -> Generator Float +float a b = + Generator (\seed0 -> + let + -- Get 64 bits of randomness + seed1 = + next seed0 + + n0 = + peel seed0 + + n1 = + peel seed1 + + -- Get a uniformly distributed IEEE-754 double between 0.0 and 1.0 + hi = + toFloat (Bitwise.and 0x03FFFFFF n0) * 1.0 + + lo = + toFloat (Bitwise.and 0x07FFFFFF n1) * 1.0 + + val = + -- These magic constants are 2^27 and 2^53 + ((hi * 134217728.0) + lo) / 9007199254740992.0 + + -- Scale it into our range + range = + abs (b - a) + + scaled = + val * range + a + in + ( scaled, next seed1 ) + ) + + +{-| Generate the same value every time. + + import Random + + alwaysFour : Random.Generator Int + alwaysFour = + Random.constant 4 + +Think of it as picking from a hat with only one thing in it. It is weird, +but it can be useful with [`elm-community/random-extra`][extra] which has +tons of nice helpers. + +[extra]: /packages/elm-community/random-extra/latest +-} +constant : a -> Generator a +constant value = + Generator (\seed -> (value, seed)) + + + +-- DATA STRUCTURES + + +{-| Generate a pair of random values. A common use of this might be to generate +a point in a certain 2D space: + + import Random + + randomPoint : Random.Generator (Float, Float) + randomPoint = + Random.pair (Random.float -200 200) (Random.float -100 100) + +Maybe you are doing an animation with SVG and want to randomly generate some +entities? +-} +pair : Generator a -> Generator b -> Generator (a,b) +pair genA genB = + map2 (\a b -> (a,b)) genA genB + + +{-| Generate a list of random values. + + import Random + + tenFractions : Random.Generator (List Float) + tenFractions = + Random.list 10 (Random.float 0 1) + + fiveGrades : Random.Generator (List Int) + fiveGrades = + Random.list 5 (int 0 100) + +If you want to generate a list with a random length, you need to use +[`andThen`](#andThen) like this: + + fiveToTenDigits : Random.Generator (List Int) + fiveToTenDigits = + Random.int 5 10 + |> Random.andThen (\len -> Random.list len (Random.int 0 9)) + +This generator gets a random integer between five and ten **and then** +uses that to generate a random list of digits. +-} +list : Int -> Generator a -> Generator (List a) +list n (Generator gen) = + Generator (\seed -> + listHelp [] n gen seed + ) + + +listHelp : List a -> Int -> (Seed -> (a,Seed)) -> Seed -> (List a, Seed) +listHelp revList n gen seed = + if n < 1 then + (revList, seed) + + else + let + (value, newSeed) = + gen seed + in + listHelp (value :: revList) (n-1) gen newSeed + + + +-- ENUMERATIONS + + +{-| Generate values with equal probability. Say we want a random suit for some +cards: + + import Random + + type Suit = Diamond | Club | Heart | Spade + + suit : Random.Generator Suit + suit = + Random.uniform Diamond [ Club, Heart, Spade ] + +That generator produces all `Suit` values with equal probability, 25% each. + +**Note:** Why not have `uniform : List a -> Generator a` as the API? It looks +a little prettier in code, but it leads to an awkward question. What do you do +with `uniform []`? How can it produce an `Int` or `Float`? The current API +guarantees that we always have *at least* one value, so we never run into that +question! +-} +uniform : a -> List a -> Generator a +uniform value valueList = + weighted (addOne value) (List.map addOne valueList) + + +addOne : a -> (Float, a) +addOne value = + ( 1, value ) + + +{-| Generate values with a _weighted_ probability. Say we want to simulate a +[loaded die](https://en.wikipedia.org/wiki/Dice#Loaded_dice) that lands +on ⚄ and ⚅ more often than the other faces: + + import Random + + type Face = One | Two | Three | Four | Five | Six + + roll : Random.Generator Face + roll = + Random.weighted + (10, One) + [ (10, Two) + , (10, Three) + , (10, Four) + , (20, Five) + , (40, Six) + ] + +So there is a 40% chance of getting `Six`, a 20% chance of getting `Five`, and +then a 10% chance for each of the remaining faces. + +**Note:** I made the weights add up to 100, but that is not necessary. I always +add up your weights into a `total`, and from there, the probablity of each case +is `weight / total`. Negative weights do not really make sense, so I just flip +them to be positive. +-} +weighted : (Float, a) -> List (Float, a) -> Generator a +weighted first others = + let + normalize (weight, _) = + abs weight + + total = + normalize first + List.sum (List.map normalize others) + in + map (getByWeight first others) (float 0 total) + + +getByWeight : (Float, a) -> List (Float, a) -> Float -> a +getByWeight (weight, value) others countdown = + case others of + [] -> + value + + second :: otherOthers -> + if countdown <= abs weight then + value + else + getByWeight second otherOthers (countdown - abs weight) + + + +-- CUSTOM GENERATORS + + +{-| Transform the values produced by a generator. For example, we can +generate random boolean values: + + import Random + + bool : Random.Generator Bool + bool = + Random.map (\n -> n < 20) (Random.int 1 100) + +The `bool` generator first picks a number between 1 and 100. From there +it checks if the number is less than twenty. So the resulting `Bool` will +be `True` about 20% of the time. + +You could also do this for lower case ASCII letters: + + letter : Random.Generator Char + letter = + Random.map (\n -> Char.fromCode (n + 97)) (Random.int 0 25) + +The `letter` generator first picks a number between 0 and 25 inclusive. +It then uses `Char.fromCode` to turn [ASCII codes][ascii] into `Char` values. + +**Note:** Instead of making these yourself, always check if the +[`random-extra`][extra] package has what you need! + +[ascii]: https://en.wikipedia.org/wiki/ASCII#Printable_characters +[extra]: /packages/elm-community/random-extra/latest +-} +map : (a -> b) -> Generator a -> Generator b +map func (Generator genA) = + Generator (\seed0 -> + let + (a, seed1) = genA seed0 + in + (func a, seed1) + ) + + +{-| Combine two generators. Maybe we have a space invaders game and want to +generate enemy ships with a random location: + + import Random + + type alias Enemy + { health : Float + , rotation : Float + , x : Float + , y : Float + } + + enemy : Random.Generator Enemy + enemy = + Random.map2 + (\x y -> Enemy 100 0 x y) + (Random.float 0 100) + (Random.float 0 100) + +Now whenever we run the `enemy` generator we get an enemy with full health, +no rotation, and a random position! Now say we want to start with between +five and ten enemies on screen: + + initialEnemies : Random.Generator (List Enemy) + initialEnemies = + Random.int 5 10 + |> Random.andThen (\num -> Random.list num enemy) + +We will generate a number between five and ten, **and then** generate +that number of enemies! + +**Note:** Snapping generators together like this is very important! Always +start by with generators for each `type` you need, and then snap them +together. +-} +map2 : (a -> b -> c) -> Generator a -> Generator b -> Generator c +map2 func (Generator genA) (Generator genB) = + Generator (\seed0 -> + let + (a, seed1) = genA seed0 + (b, seed2) = genB seed1 + in + (func a b, seed2) + ) + + +{-| Combine three generators. Maybe you want to make a simple slot machine? + + import Random + + type alias Spin = + { one : Symbol + , two : Symbol + , three : Symbol + } + + type Symbol = Cherry | Seven | Bar | Grapes + + spin : Random.Generator Spin + spin = + Random.map3 Spin symbol symbol symbol + + symbol : Random.Generator Symbol + symbol = + Random.uniform Cherry [ Seven, Bar, Grapes ] + +**Note:** Always start with the types. Make a generator for each thing you need +and then put them all together with one of these `map` functions. +-} +map3 : (a -> b -> c -> d) -> Generator a -> Generator b -> Generator c -> Generator d +map3 func (Generator genA) (Generator genB) (Generator genC) = + Generator (\seed0 -> + let + (a, seed1) = genA seed0 + (b, seed2) = genB seed1 + (c, seed3) = genC seed2 + in + (func a b c, seed3) + ) + + +{-| Combine four generators. + +Say you are making game and want to place enemies or terrain randomly. You +_could_ generate a [quadtree](https://en.wikipedia.org/wiki/Quadtree)! + + import Random + + type QuadTree a + = Empty + | Leaf a + | Node (QuadTree a) (QuadTree a) (QuadTree a) (QuadTree a) + + quadTree : Random.Generator a -> Random.Generator (QuadTree a) + quadTree leafGen = + let + subQuads = + Random.lazy (\_ -> quadTree leafGen) + in + Random.andThen identity <| + Random.uniform + (Random.constant Empty) + [ Random.map Leaf leafGen + , Random.map4 Node subQuad subQuad subQuad subQuad + ] + +We start by creating a `QuadTree` type where each quadrant is either `Empty`, a +`Leaf` containing something interesting, or a `Node` with four sub-quadrants. + +Next the `quadTree` definition describes how to generate these values. A third +of a time you get an `Empty` tree. A third of the time you get a `Leaf` with +some interesting value. And a third of the time you get a `Node` full of more +`QuadTree` values. How are those subtrees generated though? Well, we use our +`quadTree` generator! + +**Exercises:** Can `quadTree` generate infinite `QuadTree` values? Is there +some way to limit the depth of the `QuadTree`? Can you render the `QuadTree` +to HTML using absolute positions and fractional dimensions? Can you render +the `QuadTree` to SVG? + +**Note:** Check out the docs for [`lazy`](#lazy) to learn why that is needed +to define a recursive `Generator` like this one. +-} +map4 : (a -> b -> c -> d -> e) -> Generator a -> Generator b -> Generator c -> Generator d -> Generator e +map4 func (Generator genA) (Generator genB) (Generator genC) (Generator genD) = + Generator (\seed0 -> + let + (a, seed1) = genA seed0 + (b, seed2) = genB seed1 + (c, seed3) = genC seed2 + (d, seed4) = genD seed3 + in + (func a b c d, seed4) + ) + + +{-| Combine five generators. + +If you need to combine more things, you can always do it by chaining +[`andThen`](#andThen). There are also some additional helpers for this +in [`elm-community/random-extra`][extra]. + +[extra]: /packages/elm-community/random-extra/latest +-} +map5 : (a -> b -> c -> d -> e -> f) -> Generator a -> Generator b -> Generator c -> Generator d -> Generator e -> Generator f +map5 func (Generator genA) (Generator genB) (Generator genC) (Generator genD) (Generator genE) = + Generator (\seed0 -> + let + (a, seed1) = genA seed0 + (b, seed2) = genB seed1 + (c, seed3) = genC seed2 + (d, seed4) = genD seed3 + (e, seed5) = genE seed4 + in + (func a b c d e, seed5) + ) + + +{-| Generate fancy random values. + +We have seen examples of how `andThen` can be used to generate variable length +lists in the [`list`](#list) and [`map2`](#map2) docs. We saw how it could help +generate a quadtree in the [`map4`](#map4) docs. + +Anything you could ever want can be defined using this operator! As one last +example, here is how you can define `map` using `andThen`: + + import Random + + map : (a -> b) -> Random.Generator a -> Random.Generator b + map func generator = + generator + |> Random.andThen (\value -> Random.constant (func value)) + +The `andThen` function gets used a lot in [`elm-community/random-extra`][extra], +so it may be helpful to look through the implementation there for more examples. + +[extra]: /packages/elm-community/random-extra/latest +-} +andThen : (a -> Generator b) -> Generator a -> Generator b +andThen callback (Generator genA) = + Generator (\seed -> + let + (result, newSeed) = genA seed + (Generator genB) = callback result + in + genB newSeed + ) + + +{-| Helper for defining self-recursive generators. Say we want to generate a +random number of probabilities: + + import Random + + probabilities : Random.Generator (List Float) + probabilities = + Random.andThen identity <| + Random.uniform + (Random.constant []) + [ Random.map2 (::) + (Random.float 0 1) + (Random.lazy (\_ -> probabilities)) + ] + +In 50% of cases we end the list. In 50% of cases we generate a probability and +add it onto a random number of probabilities. The `lazy` call is crucial +because it means we do not unroll the generator unless we need to. + +This is a pretty subtle issue, so I recommend reading more about it +[here](https://elm-lang.org/0.19.0/bad-recursion)! + +**Note:** You can delay evaluation with `andThen` too. The thing that matters +is that you have a function call that delays the creation of the generator! +-} +lazy : (() -> Generator a) -> Generator a +lazy callback = + Generator (\seed -> + let + (Generator gen) = callback () + in + gen seed + ) + + +-- IMPLEMENTATION + +{- Explanation of the PCG algorithm + + This is a special variation (dubbed RXS-M-SH) that produces 32 + bits of output by keeping 32 bits of state. There is one function + (next) to derive the following state and another (peel) to obtain 32 + psuedo-random bits from the current state. + + Getting the next state is easy: multiply by a magic factor, modulus by 2^32, + and then add an increment. If two seeds have different increments, + their random numbers from the two seeds will never match up; they are + completely independent. This is very helpful for isolated components or + multithreading, and elm-test relies on this feature. + + Transforming a seed into 32 random bits is more complicated, but + essentially you use the "most random" bits to pick some way of scrambling + the remaining bits. Beyond that, see section 6.3.4 of the [paper]. + + [paper](http://www.pcg-random.org/paper.html) + + Once we have 32 random bits, we have to turn it into a number. For integers, + we first check if the range is a power of two. If it is, we can mask part of + the value and be done. If not, we need to account for bias. + + Let's say you want a random number between 1 and 7 but I can only generate + random numbers between 1 and 32. If I modulus by result by 7, I'm biased, + because there are more random numbers that lead to 1 than 7. So instead, I + check to see if my random number exceeds 28 (the largest multiple of 7 less + than 32). If it does, I reroll, otherwise I mod by seven. This sounds + wasteful, except that instead of 32 it's 2^32, so in practice it's hard to + notice. So that's how we get random ints. There's another process from + floats, but I don't understand it very well. +-} + + +{-| Maybe you do not want to use [`generate`](#generate) for some reason? Maybe +you need to be able to exactly reproduce a sequence of random values? + +In that case, you can work with a `Seed` of randomness and [`step`](#step) it +forward by hand. +-} +type Seed + = Seed Int Int + -- the first Int is the state of the RNG and stepped with each random generation + -- the second state is the increment which corresponds to an independent RNG + + +-- step the RNG to produce the next seed +-- this is incredibly simple: multiply the state by a constant factor, modulus it +-- by 2^32, and add a magic addend. The addend can be varied to produce independent +-- RNGs, so it is stored as part of the seed. It is given to the new seed unchanged. +next : Seed -> Seed +next (Seed state0 incr) = + -- The magic constant is from Numerical Recipes and is inlined for perf. + Seed (Bitwise.shiftRightZfBy 0 ((state0 * 1664525) + incr)) incr + + +-- obtain a psuedorandom 32-bit integer from a seed +peel : Seed -> Int +peel (Seed state _) = + -- This is the RXS-M-SH version of PCG, see section 6.3.4 of the paper + -- and line 184 of pcg_variants.h in the 0.94 (non-minimal) C implementation, + -- the latter of which is the source of the magic constant. + let + word = + (Bitwise.xor state (Bitwise.shiftRightZfBy ((Bitwise.shiftRightZfBy 28 state) + 4) state)) * 277803737 + in + Bitwise.shiftRightZfBy 0 (Bitwise.xor (Bitwise.shiftRightZfBy 22 word) word) + + +{-| A `Generator` is a **recipe** for generating random values. For example, +here is a generator for numbers between 1 and 10 inclusive: + + import Random + + oneToTen : Random.Generator Int + oneToTen = + Random.int 1 10 + +Notice that we are not actually generating any numbers yet! We are describing +what kind of values we want. To actually get random values, you create a +command with the [`generate`](#generate) function: + + type Msg = NewNumber Int + + newNumber : Cmd Msg + newNumber = + Random.generate NewNumber oneToTen + +Each time you run this command, it runs the `oneToTen` generator and produces +random integers between one and ten. + +**Note 1:** If you are not familiar with commands yet, start working through +[guide.elm-lang.org][guide]. It builds up to an example that generates +random numbers. Commands are one of the core concepts in Elm, and it will +be faster overall to invest in understanding them _now_ rather than copy/pasting +your way to frustration! And if you feel stuck on something, definitely ask +about it in [the Elm slack][slack]. Folks are happy to help! + +**Note 2:** The random `Generator` API is quite similar to the JSON `Decoder` API. +Both are building blocks that snap together with `map`, `map2`, etc. You can read +more about JSON decoders [here][json] to see the similarity. + +[guide]: https://guide.elm-lang.org/ +[slack]: https://elmlang.herokuapp.com/ +[json]: https://guide.elm-lang.org/interop/json.html +-} +type Generator a = + Generator (Seed -> (a, Seed)) + + +{-| So you need _reproducable_ randomness for some reason. + +This `step` function lets you use a `Generator` without commands. It is a +normal Elm function. Same input, same output! So to get a 3D point you could +say: + + import Random + + type alias Point3D = { x : Float, y : Float, z : Float } + + point3D : Random.Seed -> (Point3D, Random.Seed) + point3D seed0 = + let + (x, seed1) = Random.step (Random.int 0 100) seed0 + (y, seed2) = Random.step (Random.int 0 100) seed1 + (z, seed3) = Random.step (Random.int 0 100) seed2 + in + ( Point3D x y z, seed3 ) + +Notice that we use different seeds on each line! If we instead used `seed0` +for everything, the `x`, `y`, and `z` values would always be exactly the same! +Same input, same output! + +Threading seeds around is not super fun, so if you really need this, it is +best to build your `Generator` like normal and then just `step` it all at +once at the top of your program. +-} +step : Generator a -> Seed -> (a, Seed) +step (Generator generator) seed = + generator seed + + +{-| Create a `Seed` for _reproducable_ randomness. + + import Random + + seed0 : Random.Seed + seed0 = + Random.initialSeed 42 + +If you hard-code your `Seed` like this, every run will be the same. This can +be useful if you are testing a game with randomness and want it to be easy to +reproduce past games. + +In practice, you may want to get the initial seed by (1) sending it to Elm +through flags or (2) using `Time.now` to get a number that the user has not +seen before. (Flags are described on [this page][flags].) + +[flags]: https://guide.elm-lang.org/interop/flags.html +-} +initialSeed : Int -> Seed +initialSeed x = + let + -- the default increment magic constant is taken from Numerical Recipes + (Seed state1 incr) = + next (Seed 0 1013904223) + + state2 = + Bitwise.shiftRightZfBy 0 (state1 + x) + in + next (Seed state2 incr) + + +{-| A generator that produces a seed that is independent of any other seed in +the program. These seeds will generate their own unique sequences of random +values. They are useful when you need an unknown amount of randomness *later* +but can request only a fixed amount of randomness *now*. + +The independent seeds are extremely likely to be distinct for all practical +purposes. However, it is not proven that there are no pathological cases. +-} +independentSeed : Generator Seed +independentSeed = + Generator <| + \seed0 -> + let + gen = + int 0 0xFFFFFFFF + + {-- + Although it probably doesn't hold water theoretically, xor two + random numbers to make an increment less likely to be + pathological. Then make sure that it's odd, which is required. + Next make sure it is positive. Finally step it once before use. + --} + makeIndependentSeed state b c = + next <| Seed state <| + Bitwise.shiftRightZfBy 0 (Bitwise.or 1 (Bitwise.xor b c)) + in + step (map3 makeIndependentSeed gen gen gen) seed0 + + + +-- MANAGER + + +{-| Create a command that produces random values. Say you want to generate +random points: + + import Random + + point : Random.Generator (Int, Int) + point = + Random.pair (Random.int -100 100) (Random.int -100 100) + + type Msg = NewPoint (Int, Int) + + newPoint : Cmd Msg + newPoint = + Random.generate NewPoint point + +Each time you run the `newPoint` command, it will produce a new 2D point like +`(57, 18)` or `(-82, 6)`. + +**Note:** Read through [guide.elm-lang.org][guide] to learn how commands work. +If you are coming from JS it can be hopelessly frustrating if you just try to +wing it. And definitely ask around on Slack if you feel stuck! Investing in +understanding generators is really worth it, and once it clicks, folks often +dread going back to `Math.random()` in JavaScript. + +[guide]: https://guide.elm-lang.org/ +-} +generate : (a -> msg) -> Generator a -> Cmd msg +generate tagger generator = + command (Generate (map tagger generator)) + + +type MyCmd msg = Generate (Generator msg) + + +cmdMap : (a -> b) -> MyCmd a -> MyCmd b +cmdMap func (Generate generator) = + Generate (map func generator) + + +init : Task Never Seed +init = + Task.andThen (\time -> Task.succeed (initialSeed (Time.posixToMillis time))) Time.now + + +onEffects : Platform.Router msg Never -> List (MyCmd msg) -> Seed -> Task Never Seed +onEffects router commands seed = + case commands of + [] -> + Task.succeed seed + + Generate generator :: rest -> + let + (value, newSeed) = + step generator seed + in + Task.andThen + (\_ -> onEffects router rest newSeed) + (Platform.sendToApp router value) + + +onSelfMsg : Platform.Router msg Never -> Never -> Seed -> Task Never Seed +onSelfMsg _ _ seed = + Task.succeed seed diff --git a/src/Time.elm b/src/Time.elm index 2d2e601a..4a0f0635 100644 --- a/src/Time.elm +++ b/src/Time.elm @@ -42,7 +42,6 @@ import Elm.Kernel.Time import List exposing ((::)) import Maybe exposing (Maybe(..)) import Platform -import Platform.Raw.Channel as Channel import Platform.Raw.Sub as RawSub import Platform.Sub exposing (Sub) import Process From 64110f43283d3121ee091a234bd4516097da597b Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 19:58:37 +0100 Subject: [PATCH 168/170] format --- src/Platform.elm | 1 - src/Random.elm | 646 +++++++++++++++++++++++++++-------------------- 2 files changed, 376 insertions(+), 271 deletions(-) diff --git a/src/Platform.elm b/src/Platform.elm index 24f256a1..72c4c9d3 100644 --- a/src/Platform.elm +++ b/src/Platform.elm @@ -227,7 +227,6 @@ setupEffectsChannel sendToApp2 = Ok (Just msg) -> Impure.unwrapFunction (sendToApp2 msg) AsyncUpdate - Ok Nothing -> () diff --git a/src/Random.elm b/src/Random.elm index 5c68ccb7..7cba4777 100644 --- a/src/Random.elm +++ b/src/Random.elm @@ -1,13 +1,12 @@ effect module Random where { command = MyCmd } exposing - ( Generator, Seed - , int, float, uniform, weighted, constant - , list, pair - , map, map2, map3, map4, map5 - , andThen, lazy - , minInt, maxInt - , generate - , step, initialSeed, independentSeed - ) + ( Generator, generate + , int, float, uniform, weighted, constant + , pair, list + , map, map2, map3, map4, map5 + , andThen, lazy + , maxInt, minInt + , Seed, step, initialSeed, independentSeed + ) {-| This library helps you generate pseudo-random values. @@ -19,24 +18,37 @@ by M. E. O'Neil. It is not cryptographically secure. # Generators + @docs Generator, generate + # Primitives + @docs int, float, uniform, weighted, constant + # Data Structures + @docs pair, list + # Mapping + @docs map, map2, map3, map4, map5 + # Fancy Stuff + @docs andThen, lazy + # Constants + @docs maxInt, minInt + # Generate Values Manually + @docs Seed, step, initialSeed, independentSeed -} @@ -70,8 +82,9 @@ import Time anyInt = Random.int Random.minInt Random.maxInt -This generator *can* produce values outside of the range [[`minInt`](#minInt), +This generator _can_ produce values outside of the range [[`minInt`](#minInt), [`maxInt`](#maxInt)] but sufficient randomness is not guaranteed. + -} int : Int -> Int -> Generator Int int a b = @@ -81,37 +94,40 @@ int a b = ( lo, hi ) = if a < b then ( a, b ) + else ( b, a ) range = hi - lo + 1 in - -- fast path for power of 2 - if (Bitwise.and (range - 1) range) == 0 then - ( (Bitwise.shiftRightZfBy 0 (Bitwise.and (range - 1) (peel seed0))) + lo, next seed0 ) - else - let - threshhold = - -- essentially: period % max - Bitwise.shiftRightZfBy 0 (remainderBy range (Bitwise.shiftRightZfBy 0 -range)) - - accountForBias : Seed -> ( Int, Seed ) - accountForBias seed = - let - x = - peel seed - - seedN = - next seed - in - if x < threshhold then - -- in practice this recurses almost never - accountForBias seedN - else - ( remainderBy range x + lo, seedN ) - in - accountForBias seed0 + -- fast path for power of 2 + if Bitwise.and (range - 1) range == 0 then + ( Bitwise.shiftRightZfBy 0 (Bitwise.and (range - 1) (peel seed0)) + lo, next seed0 ) + + else + let + threshhold = + -- essentially: period % max + Bitwise.shiftRightZfBy 0 (remainderBy range (Bitwise.shiftRightZfBy 0 -range)) + + accountForBias : Seed -> ( Int, Seed ) + accountForBias seed = + let + x = + peel seed + + seedN = + next seed + in + if x < threshhold then + -- in practice this recurses almost never + accountForBias seedN + + else + ( remainderBy range x + lo, seedN ) + in + accountForBias seed0 ) @@ -119,20 +135,22 @@ int a b = It can generate values outside of that range, but they are “not as random”. The `maxInt` that works well is `2147483647`. + -} maxInt : Int maxInt = - 2147483647 + 2147483647 {-| The underlying algorithm works well in a specific range of integers. It can generate values outside of that range, but they are “not as random”. The `minInt` that works well is `-2147483648`. + -} minInt : Int minInt = - -2147483648 + -2147483648 {-| Generate floats in a given range. @@ -151,39 +169,41 @@ This becomes very powerful when paired with functions like [`map`](#map) and [`andThen`](#andThen). Rather than dealing with twenty random float messages in your `update`, you can build up sophisticated logic in the `Generator` itself! + -} float : Float -> Float -> Generator Float float a b = - Generator (\seed0 -> - let - -- Get 64 bits of randomness - seed1 = - next seed0 + Generator + (\seed0 -> + let + -- Get 64 bits of randomness + seed1 = + next seed0 - n0 = - peel seed0 + n0 = + peel seed0 - n1 = - peel seed1 + n1 = + peel seed1 - -- Get a uniformly distributed IEEE-754 double between 0.0 and 1.0 - hi = - toFloat (Bitwise.and 0x03FFFFFF n0) * 1.0 + -- Get a uniformly distributed IEEE-754 double between 0.0 and 1.0 + hi = + toFloat (Bitwise.and 0x03FFFFFF n0) * 1.0 - lo = - toFloat (Bitwise.and 0x07FFFFFF n1) * 1.0 + lo = + toFloat (Bitwise.and 0x07FFFFFF n1) * 1.0 - val = - -- These magic constants are 2^27 and 2^53 - ((hi * 134217728.0) + lo) / 9007199254740992.0 + val = + -- These magic constants are 2^27 and 2^53 + ((hi * 134217728.0) + lo) / 9007199254740992.0 - -- Scale it into our range - range = - abs (b - a) + -- Scale it into our range + range = + abs (b - a) - scaled = - val * range + a - in + scaled = + val * range + a + in ( scaled, next seed1 ) ) @@ -201,10 +221,11 @@ but it can be useful with [`elm-community/random-extra`][extra] which has tons of nice helpers. [extra]: /packages/elm-community/random-extra/latest + -} constant : a -> Generator a constant value = - Generator (\seed -> (value, seed)) + Generator (\seed -> ( value, seed )) @@ -216,16 +237,17 @@ a point in a certain 2D space: import Random - randomPoint : Random.Generator (Float, Float) + randomPoint : Random.Generator ( Float, Float ) randomPoint = Random.pair (Random.float -200 200) (Random.float -100 100) Maybe you are doing an animation with SVG and want to randomly generate some entities? + -} -pair : Generator a -> Generator b -> Generator (a,b) +pair : Generator a -> Generator b -> Generator ( a, b ) pair genA genB = - map2 (\a b -> (a,b)) genA genB + map2 (\a b -> ( a, b )) genA genB {-| Generate a list of random values. @@ -246,29 +268,31 @@ If you want to generate a list with a random length, you need to use fiveToTenDigits : Random.Generator (List Int) fiveToTenDigits = Random.int 5 10 - |> Random.andThen (\len -> Random.list len (Random.int 0 9)) + |> Random.andThen (\len -> Random.list len (Random.int 0 9)) This generator gets a random integer between five and ten **and then** uses that to generate a random list of digits. + -} list : Int -> Generator a -> Generator (List a) list n (Generator gen) = - Generator (\seed -> - listHelp [] n gen seed - ) + Generator + (\seed -> + listHelp [] n gen seed + ) -listHelp : List a -> Int -> (Seed -> (a,Seed)) -> Seed -> (List a, Seed) +listHelp : List a -> Int -> (Seed -> ( a, Seed )) -> Seed -> ( List a, Seed ) listHelp revList n gen seed = - if n < 1 then - (revList, seed) + if n < 1 then + ( revList, seed ) - else - let - (value, newSeed) = - gen seed - in - listHelp (value :: revList) (n-1) gen newSeed + else + let + ( value, newSeed ) = + gen seed + in + listHelp (value :: revList) (n - 1) gen newSeed @@ -280,28 +304,33 @@ cards: import Random - type Suit = Diamond | Club | Heart | Spade + type Suit + = Diamond + | Club + | Heart + | Spade suit : Random.Generator Suit suit = - Random.uniform Diamond [ Club, Heart, Spade ] + Random.uniform Diamond [ Club, Heart, Spade ] That generator produces all `Suit` values with equal probability, 25% each. **Note:** Why not have `uniform : List a -> Generator a` as the API? It looks a little prettier in code, but it leads to an awkward question. What do you do with `uniform []`? How can it produce an `Int` or `Float`? The current API -guarantees that we always have *at least* one value, so we never run into that +guarantees that we always have _at least_ one value, so we never run into that question! + -} uniform : a -> List a -> Generator a uniform value valueList = - weighted (addOne value) (List.map addOne valueList) + weighted (addOne value) (List.map addOne valueList) -addOne : a -> (Float, a) +addOne : a -> ( Float, a ) addOne value = - ( 1, value ) + ( 1, value ) {-| Generate values with a _weighted_ probability. Say we want to simulate a @@ -310,18 +339,24 @@ on ⚄ and ⚅ more often than the other faces: import Random - type Face = One | Two | Three | Four | Five | Six + type Face + = One + | Two + | Three + | Four + | Five + | Six roll : Random.Generator Face roll = - Random.weighted - (10, One) - [ (10, Two) - , (10, Three) - , (10, Four) - , (20, Five) - , (40, Six) - ] + Random.weighted + ( 10, One ) + [ ( 10, Two ) + , ( 10, Three ) + , ( 10, Four ) + , ( 20, Five ) + , ( 40, Six ) + ] So there is a 40% chance of getting `Six`, a 20% chance of getting `Five`, and then a 10% chance for each of the remaining faces. @@ -330,30 +365,32 @@ then a 10% chance for each of the remaining faces. add up your weights into a `total`, and from there, the probablity of each case is `weight / total`. Negative weights do not really make sense, so I just flip them to be positive. + -} -weighted : (Float, a) -> List (Float, a) -> Generator a +weighted : ( Float, a ) -> List ( Float, a ) -> Generator a weighted first others = - let - normalize (weight, _) = - abs weight + let + normalize ( weight, _ ) = + abs weight + + total = + normalize first + List.sum (List.map normalize others) + in + map (getByWeight first others) (float 0 total) - total = - normalize first + List.sum (List.map normalize others) - in - map (getByWeight first others) (float 0 total) +getByWeight : ( Float, a ) -> List ( Float, a ) -> Float -> a +getByWeight ( weight, value ) others countdown = + case others of + [] -> + value -getByWeight : (Float, a) -> List (Float, a) -> Float -> a -getByWeight (weight, value) others countdown = - case others of - [] -> - value + second :: otherOthers -> + if countdown <= abs weight then + value - second :: otherOthers -> - if countdown <= abs weight then - value - else - getByWeight second otherOthers (countdown - abs weight) + else + getByWeight second otherOthers (countdown - abs weight) @@ -367,7 +404,7 @@ generate random boolean values: bool : Random.Generator Bool bool = - Random.map (\n -> n < 20) (Random.int 1 100) + Random.map (\n -> n < 20) (Random.int 1 100) The `bool` generator first picks a number between 1 and 100. From there it checks if the number is less than twenty. So the resulting `Bool` will @@ -377,7 +414,7 @@ You could also do this for lower case ASCII letters: letter : Random.Generator Char letter = - Random.map (\n -> Char.fromCode (n + 97)) (Random.int 0 25) + Random.map (\n -> Char.fromCode (n + 97)) (Random.int 0 25) The `letter` generator first picks a number between 0 and 25 inclusive. It then uses `Char.fromCode` to turn [ASCII codes][ascii] into `Char` values. @@ -387,15 +424,18 @@ It then uses `Char.fromCode` to turn [ASCII codes][ascii] into `Char` values. [ascii]: https://en.wikipedia.org/wiki/ASCII#Printable_characters [extra]: /packages/elm-community/random-extra/latest + -} map : (a -> b) -> Generator a -> Generator b map func (Generator genA) = - Generator (\seed0 -> - let - (a, seed1) = genA seed0 - in - (func a, seed1) - ) + Generator + (\seed0 -> + let + ( a, seed1 ) = + genA seed0 + in + ( func a, seed1 ) + ) {-| Combine two generators. Maybe we have a space invaders game and want to @@ -423,8 +463,8 @@ five and ten enemies on screen: initialEnemies : Random.Generator (List Enemy) initialEnemies = - Random.int 5 10 - |> Random.andThen (\num -> Random.list num enemy) + Random.int 5 10 + |> Random.andThen (\num -> Random.list num enemy) We will generate a number between five and ten, **and then** generate that number of enemies! @@ -432,16 +472,21 @@ that number of enemies! **Note:** Snapping generators together like this is very important! Always start by with generators for each `type` you need, and then snap them together. + -} map2 : (a -> b -> c) -> Generator a -> Generator b -> Generator c map2 func (Generator genA) (Generator genB) = - Generator (\seed0 -> - let - (a, seed1) = genA seed0 - (b, seed2) = genB seed1 - in - (func a b, seed2) - ) + Generator + (\seed0 -> + let + ( a, seed1 ) = + genA seed0 + + ( b, seed2 ) = + genB seed1 + in + ( func a b, seed2 ) + ) {-| Combine three generators. Maybe you want to make a simple slot machine? @@ -449,34 +494,45 @@ map2 func (Generator genA) (Generator genB) = import Random type alias Spin = - { one : Symbol - , two : Symbol - , three : Symbol - } + { one : Symbol + , two : Symbol + , three : Symbol + } - type Symbol = Cherry | Seven | Bar | Grapes + type Symbol + = Cherry + | Seven + | Bar + | Grapes spin : Random.Generator Spin spin = - Random.map3 Spin symbol symbol symbol + Random.map3 Spin symbol symbol symbol symbol : Random.Generator Symbol symbol = - Random.uniform Cherry [ Seven, Bar, Grapes ] + Random.uniform Cherry [ Seven, Bar, Grapes ] **Note:** Always start with the types. Make a generator for each thing you need and then put them all together with one of these `map` functions. + -} map3 : (a -> b -> c -> d) -> Generator a -> Generator b -> Generator c -> Generator d map3 func (Generator genA) (Generator genB) (Generator genC) = - Generator (\seed0 -> - let - (a, seed1) = genA seed0 - (b, seed2) = genB seed1 - (c, seed3) = genC seed2 - in - (func a b c, seed3) - ) + Generator + (\seed0 -> + let + ( a, seed1 ) = + genA seed0 + + ( b, seed2 ) = + genB seed1 + + ( c, seed3 ) = + genC seed2 + in + ( func a b c, seed3 ) + ) {-| Combine four generators. @@ -487,22 +543,22 @@ _could_ generate a [quadtree](https://en.wikipedia.org/wiki/Quadtree)! import Random type QuadTree a - = Empty - | Leaf a - | Node (QuadTree a) (QuadTree a) (QuadTree a) (QuadTree a) + = Empty + | Leaf a + | Node (QuadTree a) (QuadTree a) (QuadTree a) (QuadTree a) quadTree : Random.Generator a -> Random.Generator (QuadTree a) quadTree leafGen = - let - subQuads = - Random.lazy (\_ -> quadTree leafGen) - in - Random.andThen identity <| - Random.uniform - (Random.constant Empty) - [ Random.map Leaf leafGen - , Random.map4 Node subQuad subQuad subQuad subQuad - ] + let + subQuads = + Random.lazy (\_ -> quadTree leafGen) + in + Random.andThen identity <| + Random.uniform + (Random.constant Empty) + [ Random.map Leaf leafGen + , Random.map4 Node subQuad subQuad subQuad subQuad + ] We start by creating a `QuadTree` type where each quadrant is either `Empty`, a `Leaf` containing something interesting, or a `Node` with four sub-quadrants. @@ -520,18 +576,27 @@ the `QuadTree` to SVG? **Note:** Check out the docs for [`lazy`](#lazy) to learn why that is needed to define a recursive `Generator` like this one. + -} map4 : (a -> b -> c -> d -> e) -> Generator a -> Generator b -> Generator c -> Generator d -> Generator e map4 func (Generator genA) (Generator genB) (Generator genC) (Generator genD) = - Generator (\seed0 -> - let - (a, seed1) = genA seed0 - (b, seed2) = genB seed1 - (c, seed3) = genC seed2 - (d, seed4) = genD seed3 - in - (func a b c d, seed4) - ) + Generator + (\seed0 -> + let + ( a, seed1 ) = + genA seed0 + + ( b, seed2 ) = + genB seed1 + + ( c, seed3 ) = + genC seed2 + + ( d, seed4 ) = + genD seed3 + in + ( func a b c d, seed4 ) + ) {-| Combine five generators. @@ -541,19 +606,30 @@ If you need to combine more things, you can always do it by chaining in [`elm-community/random-extra`][extra]. [extra]: /packages/elm-community/random-extra/latest + -} map5 : (a -> b -> c -> d -> e -> f) -> Generator a -> Generator b -> Generator c -> Generator d -> Generator e -> Generator f map5 func (Generator genA) (Generator genB) (Generator genC) (Generator genD) (Generator genE) = - Generator (\seed0 -> - let - (a, seed1) = genA seed0 - (b, seed2) = genB seed1 - (c, seed3) = genC seed2 - (d, seed4) = genD seed3 - (e, seed5) = genE seed4 - in - (func a b c d e, seed5) - ) + Generator + (\seed0 -> + let + ( a, seed1 ) = + genA seed0 + + ( b, seed2 ) = + genB seed1 + + ( c, seed3 ) = + genC seed2 + + ( d, seed4 ) = + genD seed3 + + ( e, seed5 ) = + genE seed4 + in + ( func a b c d e, seed5 ) + ) {-| Generate fancy random values. @@ -569,23 +645,28 @@ example, here is how you can define `map` using `andThen`: map : (a -> b) -> Random.Generator a -> Random.Generator b map func generator = - generator - |> Random.andThen (\value -> Random.constant (func value)) + generator + |> Random.andThen (\value -> Random.constant (func value)) The `andThen` function gets used a lot in [`elm-community/random-extra`][extra], so it may be helpful to look through the implementation there for more examples. [extra]: /packages/elm-community/random-extra/latest + -} andThen : (a -> Generator b) -> Generator a -> Generator b andThen callback (Generator genA) = - Generator (\seed -> - let - (result, newSeed) = genA seed - (Generator genB) = callback result - in - genB newSeed - ) + Generator + (\seed -> + let + ( result, newSeed ) = + genA seed + + (Generator genB) = + callback result + in + genB newSeed + ) {-| Helper for defining self-recursive generators. Say we want to generate a @@ -595,13 +676,13 @@ random number of probabilities: probabilities : Random.Generator (List Float) probabilities = - Random.andThen identity <| - Random.uniform - (Random.constant []) - [ Random.map2 (::) - (Random.float 0 1) - (Random.lazy (\_ -> probabilities)) - ] + Random.andThen identity <| + Random.uniform + (Random.constant []) + [ Random.map2 (::) + (Random.float 0 1) + (Random.lazy (\_ -> probabilities)) + ] In 50% of cases we end the list. In 50% of cases we generate a probability and add it onto a random number of probabilities. The `lazy` call is crucial @@ -612,50 +693,53 @@ This is a pretty subtle issue, so I recommend reading more about it **Note:** You can delay evaluation with `andThen` too. The thing that matters is that you have a function call that delays the creation of the generator! + -} lazy : (() -> Generator a) -> Generator a lazy callback = - Generator (\seed -> - let - (Generator gen) = callback () - in - gen seed - ) + Generator + (\seed -> + let + (Generator gen) = + callback () + in + gen seed + ) --- IMPLEMENTATION +-- IMPLEMENTATION {- Explanation of the PCG algorithm - This is a special variation (dubbed RXS-M-SH) that produces 32 - bits of output by keeping 32 bits of state. There is one function - (next) to derive the following state and another (peel) to obtain 32 - psuedo-random bits from the current state. - - Getting the next state is easy: multiply by a magic factor, modulus by 2^32, - and then add an increment. If two seeds have different increments, - their random numbers from the two seeds will never match up; they are - completely independent. This is very helpful for isolated components or - multithreading, and elm-test relies on this feature. - - Transforming a seed into 32 random bits is more complicated, but - essentially you use the "most random" bits to pick some way of scrambling - the remaining bits. Beyond that, see section 6.3.4 of the [paper]. - - [paper](http://www.pcg-random.org/paper.html) - - Once we have 32 random bits, we have to turn it into a number. For integers, - we first check if the range is a power of two. If it is, we can mask part of - the value and be done. If not, we need to account for bias. - - Let's say you want a random number between 1 and 7 but I can only generate - random numbers between 1 and 32. If I modulus by result by 7, I'm biased, - because there are more random numbers that lead to 1 than 7. So instead, I - check to see if my random number exceeds 28 (the largest multiple of 7 less - than 32). If it does, I reroll, otherwise I mod by seven. This sounds - wasteful, except that instead of 32 it's 2^32, so in practice it's hard to - notice. So that's how we get random ints. There's another process from - floats, but I don't understand it very well. + This is a special variation (dubbed RXS-M-SH) that produces 32 + bits of output by keeping 32 bits of state. There is one function + (next) to derive the following state and another (peel) to obtain 32 + psuedo-random bits from the current state. + + Getting the next state is easy: multiply by a magic factor, modulus by 2^32, + and then add an increment. If two seeds have different increments, + their random numbers from the two seeds will never match up; they are + completely independent. This is very helpful for isolated components or + multithreading, and elm-test relies on this feature. + + Transforming a seed into 32 random bits is more complicated, but + essentially you use the "most random" bits to pick some way of scrambling + the remaining bits. Beyond that, see section 6.3.4 of the [paper]. + + [paper](http://www.pcg-random.org/paper.html) + + Once we have 32 random bits, we have to turn it into a number. For integers, + we first check if the range is a power of two. If it is, we can mask part of + the value and be done. If not, we need to account for bias. + + Let's say you want a random number between 1 and 7 but I can only generate + random numbers between 1 and 32. If I modulus by result by 7, I'm biased, + because there are more random numbers that lead to 1 than 7. So instead, I + check to see if my random number exceeds 28 (the largest multiple of 7 less + than 32). If it does, I reroll, otherwise I mod by seven. This sounds + wasteful, except that instead of 32 it's 2^32, so in practice it's hard to + notice. So that's how we get random ints. There's another process from + floats, but I don't understand it very well. -} @@ -664,24 +748,31 @@ you need to be able to exactly reproduce a sequence of random values? In that case, you can work with a `Seed` of randomness and [`step`](#step) it forward by hand. + -} type Seed = Seed Int Int - -- the first Int is the state of the RNG and stepped with each random generation - -- the second state is the increment which corresponds to an independent RNG + +-- the first Int is the state of the RNG and stepped with each random generation +-- the second state is the increment which corresponds to an independent RNG -- step the RNG to produce the next seed -- this is incredibly simple: multiply the state by a constant factor, modulus it -- by 2^32, and add a magic addend. The addend can be varied to produce independent -- RNGs, so it is stored as part of the seed. It is given to the new seed unchanged. + + next : Seed -> Seed next (Seed state0 incr) = -- The magic constant is from Numerical Recipes and is inlined for perf. Seed (Bitwise.shiftRightZfBy 0 ((state0 * 1664525) + incr)) incr + -- obtain a psuedorandom 32-bit integer from a seed + + peel : Seed -> Int peel (Seed state _) = -- This is the RXS-M-SH version of PCG, see section 6.3.4 of the paper @@ -689,9 +780,9 @@ peel (Seed state _) = -- the latter of which is the source of the magic constant. let word = - (Bitwise.xor state (Bitwise.shiftRightZfBy ((Bitwise.shiftRightZfBy 28 state) + 4) state)) * 277803737 + Bitwise.xor state (Bitwise.shiftRightZfBy (Bitwise.shiftRightZfBy 28 state + 4) state) * 277803737 in - Bitwise.shiftRightZfBy 0 (Bitwise.xor (Bitwise.shiftRightZfBy 22 word) word) + Bitwise.shiftRightZfBy 0 (Bitwise.xor (Bitwise.shiftRightZfBy 22 word) word) {-| A `Generator` is a **recipe** for generating random values. For example, @@ -701,17 +792,18 @@ here is a generator for numbers between 1 and 10 inclusive: oneToTen : Random.Generator Int oneToTen = - Random.int 1 10 + Random.int 1 10 Notice that we are not actually generating any numbers yet! We are describing what kind of values we want. To actually get random values, you create a command with the [`generate`](#generate) function: - type Msg = NewNumber Int + type Msg + = NewNumber Int newNumber : Cmd Msg newNumber = - Random.generate NewNumber oneToTen + Random.generate NewNumber oneToTen Each time you run this command, it runs the `oneToTen` generator and produces random integers between one and ten. @@ -730,9 +822,10 @@ more about JSON decoders [here][json] to see the similarity. [guide]: https://guide.elm-lang.org/ [slack]: https://elmlang.herokuapp.com/ [json]: https://guide.elm-lang.org/interop/json.html + -} -type Generator a = - Generator (Seed -> (a, Seed)) +type Generator a + = Generator (Seed -> ( a, Seed )) {-| So you need _reproducable_ randomness for some reason. @@ -743,15 +836,21 @@ say: import Random - type alias Point3D = { x : Float, y : Float, z : Float } + type alias Point3D = + { x : Float, y : Float, z : Float } - point3D : Random.Seed -> (Point3D, Random.Seed) + point3D : Random.Seed -> ( Point3D, Random.Seed ) point3D seed0 = - let - (x, seed1) = Random.step (Random.int 0 100) seed0 - (y, seed2) = Random.step (Random.int 0 100) seed1 - (z, seed3) = Random.step (Random.int 0 100) seed2 - in + let + ( x, seed1 ) = + Random.step (Random.int 0 100) seed0 + + ( y, seed2 ) = + Random.step (Random.int 0 100) seed1 + + ( z, seed3 ) = + Random.step (Random.int 0 100) seed2 + in ( Point3D x y z, seed3 ) Notice that we use different seeds on each line! If we instead used `seed0` @@ -761,10 +860,11 @@ Same input, same output! Threading seeds around is not super fun, so if you really need this, it is best to build your `Generator` like normal and then just `step` it all at once at the top of your program. + -} -step : Generator a -> Seed -> (a, Seed) +step : Generator a -> Seed -> ( a, Seed ) step (Generator generator) seed = - generator seed + generator seed {-| Create a `Seed` for _reproducable_ randomness. @@ -773,7 +873,7 @@ step (Generator generator) seed = seed0 : Random.Seed seed0 = - Random.initialSeed 42 + Random.initialSeed 42 If you hard-code your `Seed` like this, every run will be the same. This can be useful if you are testing a game with randomness and want it to be easy to @@ -784,6 +884,7 @@ through flags or (2) using `Time.now` to get a number that the user has not seen before. (Flags are described on [this page][flags].) [flags]: https://guide.elm-lang.org/interop/flags.html + -} initialSeed : Int -> Seed initialSeed x = @@ -795,16 +896,17 @@ initialSeed x = state2 = Bitwise.shiftRightZfBy 0 (state1 + x) in - next (Seed state2 incr) + next (Seed state2 incr) {-| A generator that produces a seed that is independent of any other seed in the program. These seeds will generate their own unique sequences of random -values. They are useful when you need an unknown amount of randomness *later* -but can request only a fixed amount of randomness *now*. +values. They are useful when you need an unknown amount of randomness _later_ +but can request only a fixed amount of randomness _now_. The independent seeds are extremely likely to be distinct for all practical purposes. However, it is not proven that there are no pathological cases. + -} independentSeed : Generator Seed independentSeed = @@ -821,8 +923,9 @@ independentSeed = Next make sure it is positive. Finally step it once before use. --} makeIndependentSeed state b c = - next <| Seed state <| - Bitwise.shiftRightZfBy 0 (Bitwise.or 1 (Bitwise.xor b c)) + next <| + Seed state <| + Bitwise.shiftRightZfBy 0 (Bitwise.or 1 (Bitwise.xor b c)) in step (map3 makeIndependentSeed gen gen gen) seed0 @@ -836,15 +939,16 @@ random points: import Random - point : Random.Generator (Int, Int) + point : Random.Generator ( Int, Int ) point = - Random.pair (Random.int -100 100) (Random.int -100 100) + Random.pair (Random.int -100 100) (Random.int -100 100) - type Msg = NewPoint (Int, Int) + type Msg + = NewPoint ( Int, Int ) newPoint : Cmd Msg newPoint = - Random.generate NewPoint point + Random.generate NewPoint point Each time you run the `newPoint` command, it will produce a new 2D point like `(57, 18)` or `(-82, 6)`. @@ -856,41 +960,43 @@ understanding generators is really worth it, and once it clicks, folks often dread going back to `Math.random()` in JavaScript. [guide]: https://guide.elm-lang.org/ + -} generate : (a -> msg) -> Generator a -> Cmd msg generate tagger generator = - command (Generate (map tagger generator)) + command (Generate (map tagger generator)) -type MyCmd msg = Generate (Generator msg) +type MyCmd msg + = Generate (Generator msg) cmdMap : (a -> b) -> MyCmd a -> MyCmd b cmdMap func (Generate generator) = - Generate (map func generator) + Generate (map func generator) init : Task Never Seed init = - Task.andThen (\time -> Task.succeed (initialSeed (Time.posixToMillis time))) Time.now + Task.andThen (\time -> Task.succeed (initialSeed (Time.posixToMillis time))) Time.now onEffects : Platform.Router msg Never -> List (MyCmd msg) -> Seed -> Task Never Seed onEffects router commands seed = - case commands of - [] -> - Task.succeed seed + case commands of + [] -> + Task.succeed seed - Generate generator :: rest -> - let - (value, newSeed) = - step generator seed - in - Task.andThen - (\_ -> onEffects router rest newSeed) - (Platform.sendToApp router value) + (Generate generator) :: rest -> + let + ( value, newSeed ) = + step generator seed + in + Task.andThen + (\_ -> onEffects router rest newSeed) + (Platform.sendToApp router value) onSelfMsg : Platform.Router msg Never -> Never -> Seed -> Task Never Seed onSelfMsg _ _ seed = - Task.succeed seed + Task.succeed seed From 54fa35e0afe455db9399d2bbdcdbcd4560b67204 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 23:09:41 +0100 Subject: [PATCH 169/170] fix random --- NEWS | 11 +++++++ src/Random.elm | 82 ++++++++++++++++++++++++++++++-------------------- 2 files changed, 60 insertions(+), 33 deletions(-) diff --git a/NEWS b/NEWS index dd4258ef..7171ffb4 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,17 @@ A little inline blog documenting the development of this library. +# 2020/4/26 -- Merge elm/random back into core + +In my book, things that can manage effects belong in elm/core. This merge +required replacing effect manager code with an alternative (in this case +channel based) implementation. + +The new implementation is not that nice. Maybe it will look better when I +manage to unifiy the two Task types. I think this is a case where the effect +manager abstraction really worked well. I might just have my rose tinted +specticles on. + # 2020/4/26 -- A new internal module `Platform.Raw.Impure` This module contains an abstaction for functions that **do things** when diff --git a/src/Random.elm b/src/Random.elm index 7cba4777..db521e21 100644 --- a/src/Random.elm +++ b/src/Random.elm @@ -1,4 +1,4 @@ -effect module Random where { command = MyCmd } exposing +module Random exposing ( Generator, generate , int, float, uniform, weighted, constant , pair, list @@ -56,10 +56,17 @@ by M. E. O'Neil. It is not cryptographically secure. import Basics exposing (..) import Bitwise import List exposing ((::)) +import Maybe exposing (Maybe(..)) import Platform import Platform.Cmd exposing (Cmd) +import Platform.Raw.Channel as Channel +import Platform.Raw.Scheduler as RawScheduler +import Platform.Raw.Task as RawTask +import Platform.Scheduler as Scheduler +import Result exposing (Result(..)) import Task exposing (Task) import Time +import Tuple @@ -964,39 +971,48 @@ dread going back to `Math.random()` in JavaScript. -} generate : (a -> msg) -> Generator a -> Cmd msg generate tagger generator = - command (Generate (map tagger generator)) - - -type MyCmd msg - = Generate (Generator msg) - - -cmdMap : (a -> b) -> MyCmd a -> MyCmd b -cmdMap func (Generate generator) = - Generate (map func generator) - - -init : Task Never Seed -init = - Task.andThen (\time -> Task.succeed (initialSeed (Time.posixToMillis time))) Time.now - + let + msgGen = + map tagger generator + in + command + (Channel.recv RawTask.Value (Tuple.second updateSeed) + |> RawTask.andThen + (\oldSeed -> + let + ( randomVal, newSeed ) = + step msgGen oldSeed + in + Channel.send (Tuple.first updateSeed) newSeed + |> RawTask.map (\() -> Ok (Just randomVal)) + ) + |> Scheduler.wrapTask + ) -onEffects : Platform.Router msg Never -> List (MyCmd msg) -> Seed -> Task Never Seed -onEffects router commands seed = - case commands of - [] -> - Task.succeed seed - (Generate generator) :: rest -> - let - ( value, newSeed ) = - step generator seed - in - Task.andThen - (\_ -> onEffects router rest newSeed) - (Platform.sendToApp router value) +updateSeed : Channel.Channel Seed +updateSeed = + let + ( sender, receiver ) = + Channel.rawUnbounded () + + _ = + Time.now + |> Scheduler.unwrapTask + |> RawTask.andThen + (\time -> + case time of + Ok time_ -> + Channel.send sender (initialSeed (Time.posixToMillis time_)) + + Err err -> + never err + ) + |> RawScheduler.rawSpawn + in + ( sender, receiver ) -onSelfMsg : Platform.Router msg Never -> Never -> Seed -> Task Never Seed -onSelfMsg _ _ seed = - Task.succeed seed +command : Platform.Task Never (Maybe msg) -> Cmd msg +command = + Elm.Kernel.Platform.command From 04d77eca1b1e8114d73980664360133e30e551f5 Mon Sep 17 00:00:00 2001 From: Harry Sarson Date: Sun, 26 Apr 2020 23:27:39 +0100 Subject: [PATCH 170/170] fix tests --- tests/elm.json | 4 +--- tests/run-tests.sh | 56 +--------------------------------------------- 2 files changed, 2 insertions(+), 58 deletions(-) diff --git a/tests/elm.json b/tests/elm.json index f0d0a6a8..cbd6a1f6 100644 --- a/tests/elm.json +++ b/tests/elm.json @@ -4,9 +4,7 @@ "elm-version": "0.19.1", "dependencies": { "direct": { - "elm/browser": "1.0.1", - "elm/core": "1.0.2", - "elm/html": "1.0.0" + "elm/core": "1.0.5" }, "indirect": { "elm/json": "1.1.3", diff --git a/tests/run-tests.sh b/tests/run-tests.sh index fe77659b..4bbd17b6 100755 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -8,66 +8,12 @@ if [ -z "${ELM_TEST:-}" ]; then ELM_TEST=elm-test; fi -# since elm/core is treated specially by the compiler (it's always -# inserted as a dependency even when not declared explicitly), we use -# a bit of a hack to make the tests run against the local source code -# rather than the elm/core source fetched from package.elm-lang.org. - -# create a local directory where the compiler will look for the -# elm/core source code: - DIR="$(dirname $0)"; cd "$DIR"; export ELM_HOME="$(pwd)/.elm"; -rm -rf "$ELM_HOME" && mkdir -p "$ELM_HOME"; - -# elm-test also puts some things in elm-stuff, start with a clean -# slate there as well - -rm -rf elm-stuff; - -# now make an initial run of the tests to populate .elm and elm-stuff; -# this will test against elm/core from package.elm-lang.org, so we -# don't really care what the results are; we just need to force all -# the *other* dependencies to be fetched and set up. - -echo "seeding framework for test dependencies ..."; - -# '|| true' lets us ignore failures here and keep the script running. -# useful when developing a fix for a bug that exists in the version of -# elm/core hosted on package.elm-lang.org - -"${ELM_TEST}" --fuzz=1 > /dev/null || true; - -# elm make tests/Main2.elm --output ./tmp.js - -# clear out the copy of elm-core fetched by the above and replace it -# with the local source code we want to actually test - -VERSION_DIR="$(ls ${ELM_HOME}/0.19.1/packages/elm/core/)" -CORE_PACKAGE_DIR="${ELM_HOME}/0.19.1/packages/elm/core/$VERSION_DIR" -CORE_GIT_DIR="$(dirname $PWD)" - -echo; -echo "Linking $CORE_PACKAGE_DIR to $CORE_GIT_DIR" -echo; - -rm -rf "$CORE_PACKAGE_DIR" -ln -sv "$CORE_GIT_DIR" "$CORE_PACKAGE_DIR" -rm -vf "${CORE_GIT_DIR}"/*.dat "${CORE_GIT_DIR}"/doc*.json - -# we also need to clear out elm-test's elm-stuff dir, since otherwise -# the compiler complains that its .dat files are out of sync - -rm -rf elm-stuff; - -# now we can run the tests against the symlinked source code for real - -echo; -echo "running tests ..."; -echo; +../custom-core.sh .. "${ELM_TEST}" "$@";