From 4d335184ce7b282d999096795d46d27e6b46b479 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Fri, 13 Dec 2024 22:30:51 +0000 Subject: [PATCH 1/4] WIP elm mvars --- bin/index.js | 67 +------- lib/guida.sh | 10 +- src/Builder/Deps/Solver.elm | 4 + src/Builder/File.elm | 12 +- src/Builder/Http.elm | 6 +- src/Compiler/Json/Encode.elm | 2 +- src/Control/Monad/State/Strict.elm | 4 +- src/System/Exit.elm | 2 +- src/System/IO.elm | 245 +++++++++++++++-------------- src/System/Process.elm | 4 +- src/Utils/Crash.elm | 2 +- src/Utils/Main.elm | 169 ++++++++++++++++---- 12 files changed, 296 insertions(+), 231 deletions(-) diff --git a/bin/index.js b/bin/index.js index e34f83559..7d9c8a1ff 100755 --- a/bin/index.js +++ b/bin/index.js @@ -12,7 +12,7 @@ const crypto = require("node:crypto"); const AdmZip = require("adm-zip"); const which = require("which"); const tmp = require("tmp"); -const { Elm } = require("./guida.min.js"); +const { Elm } = require("./guida.js"); const FormData = require("form-data"); const rl = readline.createInterface({ @@ -21,7 +21,6 @@ const rl = readline.createInterface({ }); let nextCounter = 0; -const mVars = {}; const lockedFiles = {}; const processes = {}; @@ -353,67 +352,3 @@ app.ports.sendReplGetInputLineWithInitial.subscribe(function ({ index, prompt, l app.ports.recvReplGetInputLineWithInitial.send({ index, value }); }); }); - -// MVARS - -app.ports.sendNewEmptyMVar.subscribe(function (index) { - nextCounter += 1; - mVars[nextCounter] = { subscribers: [], value: undefined }; - app.ports.recvNewEmptyMVar.send({ index, value: nextCounter }); -}); - -app.ports.sendReadMVar.subscribe(function ({ index, id }) { - if (typeof mVars[id].value === "undefined") { - mVars[id].subscribers.push({ index, action: "read" }); - } else { - app.ports.recvReadMVar.send({ index, value: mVars[id].value }); - } -}); - -app.ports.sendTakeMVar.subscribe(function ({ index, id }) { - if (typeof mVars[id].value === "undefined") { - mVars[id].subscribers.push({ index, action: "take" }); - } else { - const value = mVars[id].value; - mVars[id].value = undefined; - - if ( - mVars[id].subscribers.length > 0 && - mVars[id].subscribers[0].action === "put" - ) { - const subscriber = mVars[id].subscribers.shift(); - mVars[id].value = subscriber.value; - app.ports.recvPutMVar.send(subscriber.index); - } - - app.ports.recvReadMVar.send({ index, value }); - } -}); - -app.ports.sendPutMVar.subscribe(function ({ index, id, value }) { - if (typeof mVars[id].value === "undefined") { - mVars[id].value = value; - - mVars[id].subscribers = mVars[id].subscribers.filter((subscriber) => { - if (subscriber.action === "read") { - app.ports.recvReadMVar.send({ index: subscriber.index, value }); - } - - return subscriber.action !== "read"; - }); - - const subscriber = mVars[id].subscribers.shift(); - - if (subscriber) { - app.ports.recvReadMVar.send({ index: subscriber.index, value }); - - if (subscriber.action === "take") { - mVars[id].value = undefined; - } - } - - app.ports.recvPutMVar.send(index); - } else { - mVars[id].subscribers.push({ index, action: "put", value }); - } -}); diff --git a/lib/guida.sh b/lib/guida.sh index f1c2c070d..22e493ffb 100755 --- a/lib/guida.sh +++ b/lib/guida.sh @@ -7,10 +7,10 @@ set -e js="bin/guida.js" min="bin/guida.min.js" -guida make --optimize --output=$js $@ +guida make --output=$js $@ -uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min +# uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min -echo "Initial size: $(cat $js | wc -c) bytes ($js)" -echo "Minified size:$(cat $min | wc -c) bytes ($min)" -echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" \ No newline at end of file +# echo "Initial size: $(cat $js | wc -c) bytes ($js)" +# echo "Minified size:$(cat $min | wc -c) bytes ($min)" +# echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" \ No newline at end of file diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index 99f2a761c..6bb18e807 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -447,6 +447,10 @@ initEnv = Utils.newEmptyMVar |> IO.bind (\mvar -> + let + _ = + Debug.log "mvar1" mvar + in Utils.forkIO (IO.bind (Utils.putMVar Http.managerEncoder mvar) Http.getManager) |> IO.bind (\_ -> diff --git a/src/Builder/File.elm b/src/Builder/File.elm index 7ac13d8c9..b6be841fc 100644 --- a/src/Builder/File.elm +++ b/src/Builder/File.elm @@ -57,7 +57,7 @@ writeBinary encoder path value = readBinary : Decode.Decoder a -> FilePath -> IO (Maybe a) readBinary decoder path = - Utils.dirDoesFileExist path + Utils.dirDoesFileExist (Debug.log "path1" path) |> IO.bind (\pathExists -> if pathExists then @@ -95,7 +95,7 @@ readBinary decoder path = writeUtf8 : FilePath -> String -> IO () writeUtf8 path content = - IO (\s -> ( s, IO.WriteString IO.pure path content )) + IO (\_ s -> ( s, IO.WriteString IO.pure path content )) @@ -104,7 +104,7 @@ writeUtf8 path content = readUtf8 : FilePath -> IO String readUtf8 path = - IO (\s -> ( s, IO.Read IO.pure path )) + IO (\_ s -> ( s, IO.Read IO.pure path )) @@ -113,7 +113,7 @@ readUtf8 path = writeBuilder : FilePath -> String -> IO () writeBuilder path builder = - IO (\s -> ( s, IO.WriteString IO.pure path builder )) + IO (\_ s -> ( s, IO.WriteString IO.pure path builder )) @@ -164,7 +164,7 @@ writeEntry destination root entry = exists : FilePath -> IO Bool exists path = - Utils.dirDoesFileExist path + Utils.dirDoesFileExist (Debug.log "path2" path) @@ -173,7 +173,7 @@ exists path = remove : FilePath -> IO () remove path = - Utils.dirDoesFileExist path + Utils.dirDoesFileExist (Debug.log "path3" path) |> IO.bind (\exists_ -> if exists_ then diff --git a/src/Builder/Http.elm b/src/Builder/Http.elm index 7bee272b8..45e85fef2 100644 --- a/src/Builder/Http.elm +++ b/src/Builder/Http.elm @@ -110,7 +110,7 @@ type Method fetch : Method -> Manager -> String -> List Header -> (Error -> e) -> (String -> IO (Result e a)) -> IO (Result e a) fetch methodVerb _ url headers _ onSuccess = IO - (\s -> + (\_ s -> ( s , IO.HttpFetch IO.pure (case methodVerb of @@ -171,7 +171,7 @@ shaToChars = getArchive : Manager -> String -> (Error -> e) -> e -> (( Sha, Zip.Archive ) -> IO (Result e a)) -> IO (Result e a) getArchive _ url _ _ onSuccess = - IO (\s -> ( s, IO.GetArchive IO.pure "GET" url )) + IO (\_ s -> ( s, IO.GetArchive IO.pure "GET" url )) |> IO.bind (\shaAndArchive -> onSuccess shaAndArchive) @@ -188,7 +188,7 @@ type MultiPart upload : Manager -> String -> List MultiPart -> IO (Result Error ()) upload _ url parts = IO - (\s -> + (\_ s -> ( s , IO.HttpUpload IO.pure url diff --git a/src/Compiler/Json/Encode.elm b/src/Compiler/Json/Encode.elm index 890df1c51..eae85f424 100644 --- a/src/Compiler/Json/Encode.elm +++ b/src/Compiler/Json/Encode.elm @@ -221,7 +221,7 @@ writeUgly path value = -} fileWriteBuilder : String -> String -> IO () fileWriteBuilder path value = - IO (\s -> ( s, IO.WriteString IO.pure path value )) + IO (\_ s -> ( s, IO.WriteString IO.pure path value )) diff --git a/src/Control/Monad/State/Strict.elm b/src/Control/Monad/State/Strict.elm index c992769e3..d163f8805 100644 --- a/src/Control/Monad/State/Strict.elm +++ b/src/Control/Monad/State/Strict.elm @@ -64,10 +64,10 @@ pure value = get : StateT s IO.ReplState get = - IO (\s -> ( s, IO.Pure s.state )) + IO (\_ s -> ( s, IO.Pure s.state )) |> liftIO put : IO.ReplState -> IO () put state = - IO (\s -> ( { s | state = state }, IO.Pure () )) + IO (\_ s -> ( { s | state = state }, IO.Pure () )) diff --git a/src/System/Exit.elm b/src/System/Exit.elm index c67c13d64..226df0bcb 100644 --- a/src/System/Exit.elm +++ b/src/System/Exit.elm @@ -16,7 +16,7 @@ type ExitCode exitWith : ExitCode -> IO a exitWith exitCode = IO - (\s -> + (\_ s -> let code : Int code = diff --git a/src/System/IO.elm b/src/System/IO.elm index 1792bfc0c..912f38125 100644 --- a/src/System/IO.elm +++ b/src/System/IO.elm @@ -11,6 +11,7 @@ port module System.IO exposing , hPutStr, hPutStrLn , putStr, putStrLn, getLine , ReplState(..), initialReplState + , RealWorldMVar, MVarSubscriber(..) ) {-| Ref.: @@ -72,8 +73,14 @@ port module System.IO exposing @docs ReplState, initialReplState + +# MVars + +@docs RealWorldMVar, MVarSubscriber + -} +import Array exposing (Array) import Codec.Archive.Zip as Zip import Dict exposing (Dict) import Json.Encode as Encode @@ -99,14 +106,13 @@ run app = { init = \flags -> update (PureMsg 0 app) - { realWorld = - { args = flags.args - , currentDirectory = flags.currentDirectory - , envVars = Dict.fromList flags.envVars - , homedir = flags.homedir - , progName = flags.progName - , state = initialReplState - } + { args = flags.args + , currentDirectory = flags.currentDirectory + , envVars = Dict.fromList flags.envVars + , homedir = flags.homedir + , progName = flags.progName + , state = initialReplState + , mVars = Array.empty , next = Dict.empty } , update = update @@ -141,17 +147,12 @@ run app = , recvDirRemoveDirectoryRecursive DirRemoveDirectoryRecursiveMsg , recvDirWithCurrentDirectory DirWithCurrentDirectoryMsg , recvReplGetInputLineWithInitial (\{ index, value } -> ReplGetInputLineWithInitialMsg index value) - , recvNewEmptyMVar (\{ index, value } -> NewEmptyMVarMsg index value) - , recvReadMVar (\{ index, value } -> ReadMVarMsg index value) - , recvPutMVar PutMVarMsg ] } type alias Model = - { realWorld : RealWorld - , next : Dict Int Next - } + RealWorld type Next @@ -184,7 +185,6 @@ type Next | DirRemoveDirectoryRecursiveNext (() -> IO ()) | DirWithCurrentDirectoryNext (() -> IO ()) | ReplGetInputLineWithInitialNext (Maybe String -> IO ()) - | NewEmptyMVarNext (Int -> IO ()) | ReadMVarNext (Encode.Value -> IO ()) | TakeMVarNext (Encode.Value -> IO ()) | PutMVarNext (() -> IO ()) @@ -220,18 +220,21 @@ type Msg | DirRemoveDirectoryRecursiveMsg Int | DirWithCurrentDirectoryMsg Int | ReplGetInputLineWithInitialMsg Int (Maybe String) - | NewEmptyMVarMsg Int Int | ReadMVarMsg Int Encode.Value | PutMVarMsg Int update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = + let + _ = + Debug.log "next" model.next + in case msg of PureMsg index (IO fn) -> - case fn model.realWorld of + case fn index model of ( newRealWorld, Pure () ) -> - ( { model | realWorld = newRealWorld } + ( newRealWorld , if index == 0 then sendExitWith 0 @@ -242,37 +245,37 @@ update msg model = ( newRealWorld, ForkIO next forkIO ) -> let ( updatedModel, updatedCmd ) = - update (PureMsg index (next ())) { model | realWorld = newRealWorld } + update (PureMsg index (next ())) newRealWorld in update (PureMsg (Dict.size model.next) forkIO) updatedModel |> Tuple.mapSecond (\cmd -> Cmd.batch [ updatedCmd, cmd ]) ( newRealWorld, GetLine next ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (GetLineNext next) model.next }, sendGetLine index ) + ( { newRealWorld | next = Dict.insert index (GetLineNext next) model.next }, sendGetLine index ) ( newRealWorld, HPutStr next (Handle fd) content ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (HPutLineNext next) model.next }, sendHPutStr { index = index, fd = fd, content = content } ) + ( { newRealWorld | next = Dict.insert index (HPutLineNext next) model.next }, sendHPutStr { index = index, fd = fd, content = content } ) ( newRealWorld, WriteString next path content ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (WriteStringNext next) model.next }, sendWriteString { index = index, path = path, content = content } ) + ( { newRealWorld | next = Dict.insert index (WriteStringNext next) model.next }, sendWriteString { index = index, path = path, content = content } ) ( newRealWorld, Read next fd ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ReadNext next) model.next }, sendRead { index = index, fd = fd } ) + ( { newRealWorld | next = Dict.insert index (ReadNext next) model.next }, sendRead { index = index, fd = fd } ) ( newRealWorld, HttpFetch next method urlStr headers ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (HttpFetchNext next) model.next }, sendHttpFetch { index = index, method = method, urlStr = urlStr, headers = headers } ) + ( { newRealWorld | next = Dict.insert index (HttpFetchNext next) model.next }, sendHttpFetch { index = index, method = method, urlStr = urlStr, headers = headers } ) ( newRealWorld, GetArchive next method url ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (GetArchiveNext next) model.next }, sendGetArchive { index = index, method = method, url = url } ) + ( { newRealWorld | next = Dict.insert index (GetArchiveNext next) model.next }, sendGetArchive { index = index, method = method, url = url } ) ( newRealWorld, HttpUpload next urlStr headers parts ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (HttpUploadNext next) model.next }, sendHttpUpload { index = index, urlStr = urlStr, headers = headers, parts = parts } ) + ( { newRealWorld | next = Dict.insert index (HttpUploadNext next) model.next }, sendHttpUpload { index = index, urlStr = urlStr, headers = headers, parts = parts } ) ( newRealWorld, HFlush next (Handle fd) ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (HFlushNext next) model.next }, sendHFlush { index = index, fd = fd } ) + ( { newRealWorld | next = Dict.insert index (HFlushNext next) model.next }, sendHFlush { index = index, fd = fd } ) ( newRealWorld, WithFile next path mode ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (WithFileNext next) model.next } + ( { newRealWorld | next = Dict.insert index (WithFileNext next) model.next } , sendWithFile { index = index , path = path @@ -293,76 +296,103 @@ update msg model = ) ( newRealWorld, HFileSize next (Handle fd) ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (HFileSizeNext next) model.next }, sendHFileSize { index = index, fd = fd } ) + ( { newRealWorld | next = Dict.insert index (HFileSizeNext next) model.next }, sendHFileSize { index = index, fd = fd } ) ( newRealWorld, ProcWithCreateProcess next createProcess ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ProcWithCreateProcessNext next) model.next }, sendProcWithCreateProcess { index = index, createProcess = createProcess } ) + ( { newRealWorld | next = Dict.insert index (ProcWithCreateProcessNext next) model.next }, sendProcWithCreateProcess { index = index, createProcess = createProcess } ) ( newRealWorld, HClose next (Handle fd) ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (HCloseNext next) model.next }, sendHClose { index = index, fd = fd } ) + ( { newRealWorld | next = Dict.insert index (HCloseNext next) model.next }, sendHClose { index = index, fd = fd } ) ( newRealWorld, ProcWaitForProcess next ph ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ProcWaitForProcessNext next) model.next }, sendProcWaitForProcess { index = index, ph = ph } ) + ( { newRealWorld | next = Dict.insert index (ProcWaitForProcessNext next) model.next }, sendProcWaitForProcess { index = index, ph = ph } ) ( newRealWorld, ExitWith next code ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ExitWithNext next) model.next }, sendExitWith code ) + ( { newRealWorld | next = Dict.insert index (ExitWithNext next) model.next }, sendExitWith code ) ( newRealWorld, DirFindExecutable next name ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirFindExecutableNext next) model.next }, sendDirFindExecutable { index = index, name = name } ) + ( { newRealWorld | next = Dict.insert index (DirFindExecutableNext next) model.next }, sendDirFindExecutable { index = index, name = name } ) ( newRealWorld, ReplGetInputLine next prompt ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ReplGetInputLineNext next) model.next }, sendReplGetInputLine { index = index, prompt = prompt } ) + ( { newRealWorld | next = Dict.insert index (ReplGetInputLineNext next) model.next }, sendReplGetInputLine { index = index, prompt = prompt } ) ( newRealWorld, DirDoesFileExist next filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirDoesFileExistNext next) model.next }, sendDirDoesFileExist { index = index, filename = filename } ) + let + _ = + Debug.log "DirDoesFileExist" ( index, filename ) + in + ( { newRealWorld | next = Dict.insert index (DirDoesFileExistNext next) model.next }, sendDirDoesFileExist { index = index, filename = filename } ) ( newRealWorld, DirCreateDirectoryIfMissing next createParents filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirCreateDirectoryIfMissingNext next) model.next }, sendDirCreateDirectoryIfMissing { index = index, createParents = createParents, filename = filename } ) + ( { newRealWorld | next = Dict.insert index (DirCreateDirectoryIfMissingNext next) model.next }, sendDirCreateDirectoryIfMissing { index = index, createParents = createParents, filename = filename } ) ( newRealWorld, LockFile next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (LockFileNext next) model.next }, sendLockFile { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (LockFileNext next) model.next }, sendLockFile { index = index, path = path } ) ( newRealWorld, UnlockFile next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (UnlockFileNext next) model.next }, sendUnlockFile { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (UnlockFileNext next) model.next }, sendUnlockFile { index = index, path = path } ) ( newRealWorld, DirGetModificationTime next filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirGetModificationTimeNext next) model.next }, sendDirGetModificationTime { index = index, filename = filename } ) + ( { newRealWorld | next = Dict.insert index (DirGetModificationTimeNext next) model.next }, sendDirGetModificationTime { index = index, filename = filename } ) ( newRealWorld, DirDoesDirectoryExist next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirDoesDirectoryExistNext next) model.next }, sendDirDoesDirectoryExist { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (DirDoesDirectoryExistNext next) model.next }, sendDirDoesDirectoryExist { index = index, path = path } ) ( newRealWorld, DirCanonicalizePath next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirCanonicalizePathNext next) model.next }, sendDirCanonicalizePath { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (DirCanonicalizePathNext next) model.next }, sendDirCanonicalizePath { index = index, path = path } ) ( newRealWorld, BinaryDecodeFileOrFail next filename ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (BinaryDecodeFileOrFailNext next) model.next }, sendBinaryDecodeFileOrFail { index = index, filename = filename } ) + ( { newRealWorld | next = Dict.insert index (BinaryDecodeFileOrFailNext next) model.next }, sendBinaryDecodeFileOrFail { index = index, filename = filename } ) ( newRealWorld, Write next fd content ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (WriteNext next) model.next }, sendWrite { index = index, fd = fd, content = content } ) + ( { newRealWorld | next = Dict.insert index (WriteNext next) model.next }, sendWrite { index = index, fd = fd, content = content } ) ( newRealWorld, DirRemoveFile next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirRemoveFileNext next) model.next }, sendDirRemoveFile { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (DirRemoveFileNext next) model.next }, sendDirRemoveFile { index = index, path = path } ) ( newRealWorld, DirRemoveDirectoryRecursive next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirRemoveDirectoryRecursiveNext next) model.next }, sendDirRemoveDirectoryRecursive { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (DirRemoveDirectoryRecursiveNext next) model.next }, sendDirRemoveDirectoryRecursive { index = index, path = path } ) ( newRealWorld, DirWithCurrentDirectory next path ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (DirWithCurrentDirectoryNext next) model.next }, sendDirWithCurrentDirectory { index = index, path = path } ) + ( { newRealWorld | next = Dict.insert index (DirWithCurrentDirectoryNext next) model.next }, sendDirWithCurrentDirectory { index = index, path = path } ) ( newRealWorld, ReplGetInputLineWithInitial next prompt left right ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ReplGetInputLineWithInitialNext next) model.next }, sendReplGetInputLineWithInitial { index = index, prompt = prompt, left = left, right = right } ) + ( { newRealWorld | next = Dict.insert index (ReplGetInputLineWithInitialNext next) model.next }, sendReplGetInputLineWithInitial { index = index, prompt = prompt, left = left, right = right } ) + + ( newRealWorld, ReadMVar next ) -> + ( { newRealWorld | next = Dict.insert index (ReadMVarNext next) model.next }, Cmd.none ) - ( newRealWorld, NewEmptyMVar next ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (NewEmptyMVarNext next) model.next }, sendNewEmptyMVar index ) + ( newRealWorld, TakeMVarWaiting next ) -> + ( { newRealWorld | next = Dict.insert index (TakeMVarNext next) model.next }, Cmd.none ) - ( newRealWorld, ReadMVar next id ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ReadMVarNext next) model.next }, sendReadMVar { index = index, id = id } ) + ( newRealWorld, TakeMVarTaken next value maybePutIndex ) -> + let + ( updatedModel, updatedCmd ) = + update (ReadMVarMsg index value) { newRealWorld | next = Dict.insert index (TakeMVarNext next) model.next } + in + case Debug.log "maybePutIndex" maybePutIndex of + Just putIndex -> + update (PutMVarMsg (Debug.log "putIndex" putIndex)) updatedModel + |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, updatedCmd ]) - ( newRealWorld, TakeMVar next id ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (TakeMVarNext next) model.next }, sendTakeMVar { index = index, id = id } ) + Nothing -> + ( updatedModel, updatedCmd ) - ( newRealWorld, PutMVar next id value ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (PutMVarNext next) model.next }, sendPutMVar { index = index, id = id, value = value } ) + ( newRealWorld, PutMVarWaiting next ) -> + ( { newRealWorld | next = Dict.insert (Debug.log "INDEX1" index) (PutMVarNext next) model.next }, Cmd.none ) + + ( newRealWorld, PutMVarDone next readSubscriberIds maybeTakeIndex value ) -> + let + _ = + Debug.log "readSubscriberIds maybeTakeIndex" ( readSubscriberIds, maybeTakeIndex ) + in + List.foldr + (\readSubscriberId ( accModel, accCmd ) -> + update (ReadMVarMsg (Debug.log "readSubscriberId" readSubscriberId) value) accModel + |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, accCmd ]) + ) + (update (PutMVarMsg index) { newRealWorld | next = Dict.insert (Debug.log "INDEX2" index) (PutMVarNext next) model.next }) + readSubscriberIds GetLineMsg index input -> case Dict.get index model.next of @@ -468,14 +498,6 @@ update msg model = _ -> crash "ProcWaitForProcessMsg" - NewEmptyMVarMsg index value -> - case Dict.get index model.next of - Just (NewEmptyMVarNext fn) -> - update (PureMsg index (fn value)) model - - _ -> - crash "NewEmptyMVarMsg" - DirFindExecutableMsg index value -> case Dict.get index model.next of Just (DirFindExecutableNext fn) -> @@ -505,8 +527,8 @@ update msg model = Just (DirDoesFileExistNext fn) -> update (PureMsg index (fn value)) model - _ -> - crash "DirDoesFileExistMsg" + nextFn -> + crash ("DirDoesFileExistMsg " ++ String.fromInt index ++ " - " ++ Debug.toString nextFn) DirCreateDirectoryIfMissingMsg index -> case Dict.get index model.next of @@ -788,36 +810,11 @@ port recvReplGetInputLineWithInitial : ({ index : Int, value : Maybe String } -> --- MVARS - - -port sendNewEmptyMVar : Int -> Cmd msg - - -port recvNewEmptyMVar : ({ index : Int, value : Int } -> msg) -> Sub msg - - -port sendReadMVar : { index : Int, id : Int } -> Cmd msg - - -port recvReadMVar : ({ index : Int, value : Encode.Value } -> msg) -> Sub msg - - -port sendTakeMVar : { index : Int, id : Int } -> Cmd msg - - -port sendPutMVar : { index : Int, id : Int, value : Encode.Value } -> Cmd msg - - -port recvPutMVar : (Int -> msg) -> Sub msg - - - -- The IO monad type IO a - = IO (RealWorld -> ( RealWorld, ION a )) + = IO (Int -> RealWorld -> ( RealWorld, ION a )) type ION a @@ -837,19 +834,20 @@ type ION a | HClose (() -> IO a) Handle | ProcWaitForProcess (Int -> IO a) Int | ExitWith (a -> IO a) Int - | NewEmptyMVar (Int -> IO a) | DirFindExecutable (Maybe FilePath -> IO a) FilePath | ReplGetInputLine (Maybe String -> IO a) String - | PutMVar (() -> IO a) Int Encode.Value + | PutMVarWaiting (() -> IO a) + | PutMVarDone (() -> IO a) (List Int) (Maybe Int) Encode.Value | DirDoesFileExist (Bool -> IO a) FilePath | DirCreateDirectoryIfMissing (() -> IO a) Bool FilePath | LockFile (() -> IO a) FilePath | UnlockFile (() -> IO a) FilePath | DirGetModificationTime (Int -> IO a) FilePath - | TakeMVar (Encode.Value -> IO a) Int + | TakeMVarWaiting (Encode.Value -> IO a) + | TakeMVarTaken (Encode.Value -> IO a) Encode.Value (Maybe Int) | DirDoesDirectoryExist (Bool -> IO a) FilePath | DirCanonicalizePath (String -> IO a) FilePath - | ReadMVar (Encode.Value -> IO a) Int + | ReadMVar (Encode.Value -> IO a) | BinaryDecodeFileOrFail (Encode.Value -> IO a) FilePath | Write (() -> IO a) FilePath Encode.Value | DirRemoveFile (() -> IO a) FilePath @@ -865,12 +863,26 @@ type alias RealWorld = , homedir : FilePath , progName : String , state : ReplState + , mVars : Array RealWorldMVar + , next : Dict Int Next } +type alias RealWorldMVar = + { subscribers : List MVarSubscriber + , value : Maybe Encode.Value + } + + +type MVarSubscriber + = ReadSubscriber Int + | TakeSubscriber Int + | PutSubscriber Int Encode.Value + + pure : a -> IO a pure x = - IO (\s -> ( s, Pure x )) + IO (\_ s -> ( s, Pure x )) apply : IO a -> IO (a -> b) -> IO b @@ -886,10 +898,10 @@ fmap fn ma = bind : (a -> IO b) -> IO a -> IO b bind f (IO ma) = IO - (\s0 -> - case ma s0 of + (\index s0 -> + case ma index s0 of ( s1, Pure a ) -> - unIO (f a) s1 + unIO (f a) index s1 ( s1, ForkIO next forkIO ) -> ( s1, ForkIO (\() -> bind f (next ())) forkIO ) @@ -981,21 +993,24 @@ bind f (IO ma) = ( s1, ReplGetInputLineWithInitial next prompt left right ) -> ( s1, ReplGetInputLineWithInitial (\value -> bind f (next value)) prompt left right ) - ( s1, NewEmptyMVar next ) -> - ( s1, NewEmptyMVar (\value -> bind f (next value)) ) + ( s1, ReadMVar next ) -> + ( s1, ReadMVar (\value -> bind f (next value)) ) + + ( s1, TakeMVarWaiting next ) -> + ( s1, TakeMVarWaiting (\value -> bind f (next value)) ) - ( s1, ReadMVar next path ) -> - ( s1, ReadMVar (\value -> bind f (next value)) path ) + ( s1, TakeMVarTaken next takenValue maybePutIndex ) -> + ( s1, TakeMVarTaken (\value -> bind f (next value)) takenValue maybePutIndex ) - ( s1, TakeMVar next path ) -> - ( s1, TakeMVar (\value -> bind f (next value)) path ) + ( s1, PutMVarWaiting next ) -> + ( s1, PutMVarWaiting (\() -> bind f (next ())) ) - ( s1, PutMVar next id value ) -> - ( s1, PutMVar (\() -> bind f (next ())) id value ) + ( s1, PutMVarDone next readSubscriberIds maybeTakeIndex value ) -> + ( s1, PutMVarDone (\() -> bind f (next ())) readSubscriberIds maybeTakeIndex value ) ) -unIO : IO a -> (RealWorld -> ( RealWorld, ION a )) +unIO : IO a -> (Int -> RealWorld -> ( RealWorld, ION a )) unIO (IO a) = a @@ -1032,7 +1047,7 @@ stderr = withFile : String -> IOMode -> (Handle -> IO a) -> IO a withFile path mode callback = - IO (\s -> ( s, WithFile pure path mode )) + IO (\_ s -> ( s, WithFile pure path mode )) |> bind (Handle >> callback) @@ -1049,7 +1064,7 @@ type IOMode hClose : Handle -> IO () hClose handle = - IO (\s -> ( s, HClose pure handle )) + IO (\_ s -> ( s, HClose pure handle )) @@ -1058,7 +1073,7 @@ hClose handle = hFileSize : Handle -> IO Int hFileSize handle = - IO (\s -> ( s, HFileSize pure handle )) + IO (\_ s -> ( s, HFileSize pure handle )) @@ -1067,7 +1082,7 @@ hFileSize handle = hFlush : Handle -> IO () hFlush handle = - IO (\s -> ( s, HFlush pure handle )) + IO (\_ s -> ( s, HFlush pure handle )) @@ -1085,7 +1100,7 @@ hIsTerminalDevice _ = hPutStr : Handle -> String -> IO () hPutStr handle content = - IO (\s -> ( s, HPutStr pure handle content )) + IO (\_ s -> ( s, HPutStr pure handle content )) hPutStrLn : Handle -> String -> IO () @@ -1109,7 +1124,7 @@ putStrLn s = getLine : IO String getLine = - IO (\s -> ( s, GetLine pure )) + IO (\_ s -> ( s, GetLine pure )) diff --git a/src/System/Process.elm b/src/System/Process.elm index bdf58fc4f..330373b0b 100644 --- a/src/System/Process.elm +++ b/src/System/Process.elm @@ -48,7 +48,7 @@ proc cmd args = withCreateProcess : CreateProcess -> (Maybe IO.Handle -> Maybe IO.Handle -> Maybe IO.Handle -> ProcessHandle -> IO Exit.ExitCode) -> IO Exit.ExitCode withCreateProcess createProcess f = IO - (\s -> + (\_ s -> ( s , IO.ProcWithCreateProcess IO.pure (Encode.object @@ -115,7 +115,7 @@ withCreateProcess createProcess f = waitForProcess : ProcessHandle -> IO Exit.ExitCode waitForProcess (ProcessHandle ph) = - IO (\s -> ( s, IO.ProcWaitForProcess IO.pure ph )) + IO (\_ s -> ( s, IO.ProcWaitForProcess IO.pure ph )) |> IO.fmap (\exitCode -> case exitCode of diff --git a/src/Utils/Crash.elm b/src/Utils/Crash.elm index 76f69679b..8ec65155b 100644 --- a/src/Utils/Crash.elm +++ b/src/Utils/Crash.elm @@ -3,4 +3,4 @@ module Utils.Crash exposing (crash) crash : String -> a crash str = - crash str + Debug.todo str diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 9cbcffbb0..6733697ad 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -123,6 +123,7 @@ module Utils.Main exposing , zipWithM ) +import Array import Basics.Extra exposing (flip) import Builder.Reporting.Task as Task exposing (Task) import Compiler.Data.Index as Index @@ -139,7 +140,7 @@ import Json.Encode as Encode import Maybe.Extra as Maybe import Prelude import System.Exit as Exit -import System.IO as IO exposing (IO(..)) +import System.IO as IO exposing (IO(..), MVarSubscriber(..)) import Time import Utils.Crash exposing (crash) @@ -723,12 +724,12 @@ lockWithFileLock path mode ioFunc = lockFile : FilePath -> IO () lockFile path = - IO (\s -> ( s, IO.LockFile IO.pure path )) + IO (\_ s -> ( s, IO.LockFile IO.pure path )) unlockFile : FilePath -> IO () unlockFile path = - IO (\s -> ( s, IO.UnlockFile IO.pure path )) + IO (\_ s -> ( s, IO.UnlockFile IO.pure path )) @@ -737,53 +738,53 @@ unlockFile path = dirDoesFileExist : FilePath -> IO Bool dirDoesFileExist filename = - IO (\s -> ( s, IO.DirDoesFileExist IO.pure filename )) + IO (\_ s -> ( s, IO.DirDoesFileExist IO.pure filename )) dirFindExecutable : FilePath -> IO (Maybe FilePath) dirFindExecutable filename = - IO (\s -> ( s, IO.DirFindExecutable IO.pure filename )) + IO (\_ s -> ( s, IO.DirFindExecutable IO.pure filename )) dirCreateDirectoryIfMissing : Bool -> FilePath -> IO () dirCreateDirectoryIfMissing createParents filename = - IO (\s -> ( s, IO.DirCreateDirectoryIfMissing IO.pure createParents filename )) + IO (\_ s -> ( s, IO.DirCreateDirectoryIfMissing IO.pure createParents filename )) dirGetCurrentDirectory : IO String dirGetCurrentDirectory = - IO (\s -> ( s, IO.Pure s.currentDirectory )) + IO (\_ s -> ( s, IO.Pure s.currentDirectory )) dirGetAppUserDataDirectory : FilePath -> IO FilePath dirGetAppUserDataDirectory filename = - IO (\s -> ( s, IO.Pure (s.homedir ++ "/." ++ filename) )) + IO (\_ s -> ( s, IO.Pure (s.homedir ++ "/." ++ filename) )) dirGetModificationTime : FilePath -> IO Time.Posix dirGetModificationTime filename = - IO (\s -> ( s, IO.DirGetModificationTime IO.pure filename )) + IO (\_ s -> ( s, IO.DirGetModificationTime IO.pure filename )) |> IO.fmap Time.millisToPosix dirRemoveFile : FilePath -> IO () dirRemoveFile path = - IO (\s -> ( s, IO.DirRemoveFile IO.pure path )) + IO (\_ s -> ( s, IO.DirRemoveFile IO.pure path )) dirRemoveDirectoryRecursive : FilePath -> IO () dirRemoveDirectoryRecursive path = - IO (\s -> ( s, IO.DirRemoveDirectoryRecursive IO.pure path )) + IO (\_ s -> ( s, IO.DirRemoveDirectoryRecursive IO.pure path )) dirDoesDirectoryExist : FilePath -> IO Bool dirDoesDirectoryExist path = - IO (\s -> ( s, IO.DirDoesDirectoryExist IO.pure path )) + IO (\_ s -> ( s, IO.DirDoesDirectoryExist IO.pure path )) dirCanonicalizePath : FilePath -> IO FilePath dirCanonicalizePath path = - IO (\s -> ( s, IO.DirCanonicalizePath IO.pure path )) + IO (\_ s -> ( s, IO.DirCanonicalizePath IO.pure path )) dirWithCurrentDirectory : FilePath -> IO a -> IO a @@ -792,8 +793,8 @@ dirWithCurrentDirectory dir action = |> IO.bind (\currentDir -> bracket_ - (IO (\s -> ( s, IO.DirWithCurrentDirectory IO.pure dir ))) - (IO (\s -> ( s, IO.DirWithCurrentDirectory IO.pure currentDir ))) + (IO (\_ s -> ( s, IO.DirWithCurrentDirectory IO.pure dir ))) + (IO (\_ s -> ( s, IO.DirWithCurrentDirectory IO.pure currentDir ))) action ) @@ -804,17 +805,17 @@ dirWithCurrentDirectory dir action = envLookupEnv : String -> IO (Maybe String) envLookupEnv name = - IO (\s -> ( s, IO.Pure (Dict.get name s.envVars) )) + IO (\_ s -> ( s, IO.Pure (Dict.get name s.envVars) )) envGetProgName : IO String envGetProgName = - IO (\s -> ( s, IO.Pure s.progName )) + IO (\_ s -> ( s, IO.Pure s.progName )) envGetArgs : IO (List String) envGetArgs = - IO (\s -> ( s, IO.Pure s.args )) + IO (\_ s -> ( s, IO.Pure s.args )) @@ -918,7 +919,7 @@ type ThreadId forkIO : IO () -> IO ThreadId forkIO ioArg = - IO (\s -> ( s, IO.ForkIO (\() -> IO.pure ThreadId) ioArg )) + IO (\_ s -> ( s, IO.ForkIO (\() -> IO.pure ThreadId) ioArg )) @@ -934,6 +935,10 @@ newMVar encoder value = newEmptyMVar |> IO.bind (\mvar -> + let + _ = + Debug.log "mvar2" mvar + in putMVar encoder mvar value |> IO.fmap (\_ -> mvar) ) @@ -941,7 +946,22 @@ newMVar encoder value = readMVar : Decode.Decoder a -> MVar a -> IO a readMVar decoder (MVar ref) = - IO (\s -> ( s, IO.ReadMVar IO.pure ref )) + IO + (\index s -> + case Array.get ref s.mVars of + Just mVar -> + case mVar.value of + Just value -> + ( s, IO.Pure value ) + + Nothing -> + ( { s | mVars = Array.set ref { mVar | subscribers = IO.ReadSubscriber index :: mVar.subscribers } s.mVars } + , IO.ReadMVar IO.pure + ) + + Nothing -> + crash "Utils.Main.readMVar: invalid ref" + ) |> IO.fmap (\encodedValue -> case Decode.decodeValue decoder encodedValue of @@ -966,7 +986,33 @@ modifyMVar decoder encoder m io = takeMVar : Decode.Decoder a -> MVar a -> IO a takeMVar decoder (MVar ref) = - IO (\s -> ( s, IO.TakeMVar IO.pure ref )) + IO + (\index s -> + case Array.get ref s.mVars of + Just mVar -> + case mVar.value of + Just value -> + let + ( newValue, newSubscribers, maybePutIndex ) = + case mVar.subscribers of + (IO.PutSubscriber putIndex putValue) :: restSubscribers -> + ( Just putValue, restSubscribers, Just putIndex ) + + subscribers -> + ( Nothing, subscribers, Nothing ) + in + ( { s | mVars = Array.set ref { mVar | subscribers = newSubscribers, value = newValue } s.mVars } + , IO.TakeMVarTaken IO.pure value maybePutIndex + ) + + Nothing -> + ( { s | mVars = Array.set ref { mVar | subscribers = IO.TakeSubscriber index :: mVar.subscribers } s.mVars } + , IO.TakeMVarWaiting IO.pure + ) + + Nothing -> + crash "Utils.Main.takeMVar: invalid ref" + ) |> IO.fmap (\encodedValue -> case Decode.decodeValue decoder encodedValue of @@ -980,13 +1026,78 @@ takeMVar decoder (MVar ref) = putMVar : (a -> Encode.Value) -> MVar a -> a -> IO () putMVar encoder (MVar ref) value = - IO (\s -> ( s, IO.PutMVar IO.pure ref (encoder value) )) + IO + (\index s -> + case Array.get ref s.mVars of + Just mVar -> + case mVar.value of + Just _ -> + ( { s | mVars = Array.set ref { mVar | subscribers = IO.PutSubscriber index (encoder value) :: mVar.subscribers } s.mVars } + , Debug.log "PutMVarWaiting" (IO.PutMVarWaiting IO.pure) + ) + + Nothing -> + let + encodedValue = + encoder value + + readSubscriberIds = + List.filterMap + (\subscriber -> + case subscriber of + IO.ReadSubscriber readIndex -> + Just readIndex + + _ -> + Nothing + ) + mVar.subscribers + + nonReadSubscribers = + List.filter + (\subscriber -> + case subscriber of + IO.ReadSubscriber _ -> + False + + _ -> + True + ) + mVar.subscribers + + ( newValue, maybeTakeIndex, subscribers ) = + case nonReadSubscribers of + (IO.TakeSubscriber takeIndex) :: remainingSubscribers -> + ( Nothing, Just takeIndex, remainingSubscribers ) + + all -> + let + _ = + Debug.log "ALL!!!" all + in + ( Just encodedValue, Nothing, nonReadSubscribers ) + in + ( { s | mVars = Array.set ref { mVar | subscribers = subscribers, value = newValue } s.mVars } + , Debug.log "PutMVarDone" (IO.PutMVarDone IO.pure readSubscriberIds maybeTakeIndex encodedValue) + ) + + _ -> + crash "Utils.Main.putMVar: invalid ref" + ) newEmptyMVar : IO (MVar a) newEmptyMVar = - IO (\s -> ( s, IO.NewEmptyMVar IO.pure )) - |> IO.fmap MVar + IO + (\_ s -> + let + _ = + Debug.log "newEmptyMVar" (Array.length s.mVars) + in + ( { s | mVars = Array.push { subscribers = [], value = Nothing } s.mVars } + , IO.Pure (MVar (Array.length s.mVars)) + ) + ) @@ -1055,7 +1166,7 @@ writeChan encoder (Chan _ writeVar) val = builderHPutBuilder : IO.Handle -> String -> IO () builderHPutBuilder handle str = - IO (\s -> ( s, IO.HPutStr IO.pure handle str )) + IO (\_ s -> ( s, IO.HPutStr IO.pure handle str )) @@ -1064,7 +1175,7 @@ builderHPutBuilder handle str = binaryDecodeFileOrFail : Decode.Decoder a -> FilePath -> IO (Result ( Int, String ) a) binaryDecodeFileOrFail decoder filename = - IO (\s -> ( s, IO.BinaryDecodeFileOrFail IO.pure filename )) + IO (\_ s -> ( s, IO.BinaryDecodeFileOrFail IO.pure filename )) |> IO.fmap (Decode.decodeValue decoder >> Result.mapError (\_ -> ( 0, "Could not find file " ++ filename )) @@ -1073,7 +1184,7 @@ binaryDecodeFileOrFail decoder filename = binaryEncodeFile : (a -> Encode.Value) -> FilePath -> a -> IO () binaryEncodeFile encoder path value = - IO (\s -> ( s, IO.Write IO.pure path (encoder value) )) + IO (\_ s -> ( s, IO.Write IO.pure path (encoder value) )) @@ -1118,12 +1229,12 @@ replCompleteWord _ _ _ = replGetInputLine : String -> ReplInputT (Maybe String) replGetInputLine prompt = - IO (\s -> ( s, IO.ReplGetInputLine IO.pure prompt )) + IO (\_ s -> ( s, IO.ReplGetInputLine IO.pure prompt )) replGetInputLineWithInitial : String -> ( String, String ) -> ReplInputT (Maybe String) replGetInputLineWithInitial prompt ( left, right ) = - IO (\s -> ( s, IO.ReplGetInputLineWithInitial IO.pure prompt left right )) + IO (\_ s -> ( s, IO.ReplGetInputLineWithInitial IO.pure prompt left right )) From f134fd2756e2a1aa7d353537f0b1759edf0d1d9c Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Fri, 13 Dec 2024 23:03:36 +0000 Subject: [PATCH 2/4] WIP clear debugging --- bin/index.js | 2 +- lib/guida.sh | 10 +++---- src/Builder/Deps/Solver.elm | 4 --- src/Builder/File.elm | 6 ++-- src/System/IO.elm | 55 +++++++++++++++++-------------------- src/Utils/Crash.elm | 2 +- src/Utils/Main.elm | 26 +++++------------- 7 files changed, 42 insertions(+), 63 deletions(-) diff --git a/bin/index.js b/bin/index.js index 7d9c8a1ff..50df07f1b 100755 --- a/bin/index.js +++ b/bin/index.js @@ -12,7 +12,7 @@ const crypto = require("node:crypto"); const AdmZip = require("adm-zip"); const which = require("which"); const tmp = require("tmp"); -const { Elm } = require("./guida.js"); +const { Elm } = require("./guida.min.js"); const FormData = require("form-data"); const rl = readline.createInterface({ diff --git a/lib/guida.sh b/lib/guida.sh index 22e493ffb..1443cae3a 100755 --- a/lib/guida.sh +++ b/lib/guida.sh @@ -7,10 +7,10 @@ set -e js="bin/guida.js" min="bin/guida.min.js" -guida make --output=$js $@ +elm make --optimize --output=$js $@ -# uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min +uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min -# echo "Initial size: $(cat $js | wc -c) bytes ($js)" -# echo "Minified size:$(cat $min | wc -c) bytes ($min)" -# echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" \ No newline at end of file +echo "Initial size: $(cat $js | wc -c) bytes ($js)" +echo "Minified size:$(cat $min | wc -c) bytes ($min)" +echo "Gzipped size: $(cat $min | gzip -c | wc -c) bytes" \ No newline at end of file diff --git a/src/Builder/Deps/Solver.elm b/src/Builder/Deps/Solver.elm index 6bb18e807..99f2a761c 100644 --- a/src/Builder/Deps/Solver.elm +++ b/src/Builder/Deps/Solver.elm @@ -447,10 +447,6 @@ initEnv = Utils.newEmptyMVar |> IO.bind (\mvar -> - let - _ = - Debug.log "mvar1" mvar - in Utils.forkIO (IO.bind (Utils.putMVar Http.managerEncoder mvar) Http.getManager) |> IO.bind (\_ -> diff --git a/src/Builder/File.elm b/src/Builder/File.elm index b6be841fc..4a4ec774c 100644 --- a/src/Builder/File.elm +++ b/src/Builder/File.elm @@ -57,7 +57,7 @@ writeBinary encoder path value = readBinary : Decode.Decoder a -> FilePath -> IO (Maybe a) readBinary decoder path = - Utils.dirDoesFileExist (Debug.log "path1" path) + Utils.dirDoesFileExist path |> IO.bind (\pathExists -> if pathExists then @@ -164,7 +164,7 @@ writeEntry destination root entry = exists : FilePath -> IO Bool exists path = - Utils.dirDoesFileExist (Debug.log "path2" path) + Utils.dirDoesFileExist path @@ -173,7 +173,7 @@ exists path = remove : FilePath -> IO () remove path = - Utils.dirDoesFileExist (Debug.log "path3" path) + Utils.dirDoesFileExist path |> IO.bind (\exists_ -> if exists_ then diff --git a/src/System/IO.elm b/src/System/IO.elm index 912f38125..7726c76b3 100644 --- a/src/System/IO.elm +++ b/src/System/IO.elm @@ -226,10 +226,6 @@ type Msg update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = - let - _ = - Debug.log "next" model.next - in case msg of PureMsg index (IO fn) -> case fn index model of @@ -317,10 +313,6 @@ update msg model = ( { newRealWorld | next = Dict.insert index (ReplGetInputLineNext next) model.next }, sendReplGetInputLine { index = index, prompt = prompt } ) ( newRealWorld, DirDoesFileExist next filename ) -> - let - _ = - Debug.log "DirDoesFileExist" ( index, filename ) - in ( { newRealWorld | next = Dict.insert index (DirDoesFileExistNext next) model.next }, sendDirDoesFileExist { index = index, filename = filename } ) ( newRealWorld, DirCreateDirectoryIfMissing next createParents filename ) -> @@ -359,39 +351,38 @@ update msg model = ( newRealWorld, ReplGetInputLineWithInitial next prompt left right ) -> ( { newRealWorld | next = Dict.insert index (ReplGetInputLineWithInitialNext next) model.next }, sendReplGetInputLineWithInitial { index = index, prompt = prompt, left = left, right = right } ) - ( newRealWorld, ReadMVar next ) -> + ( newRealWorld, ReadMVarWaiting next ) -> ( { newRealWorld | next = Dict.insert index (ReadMVarNext next) model.next }, Cmd.none ) + ( newRealWorld, ReadMVarDone next value ) -> + update (ReadMVarMsg index value) { newRealWorld | next = Dict.insert index (ReadMVarNext next) model.next } + ( newRealWorld, TakeMVarWaiting next ) -> ( { newRealWorld | next = Dict.insert index (TakeMVarNext next) model.next }, Cmd.none ) - ( newRealWorld, TakeMVarTaken next value maybePutIndex ) -> + ( newRealWorld, TakeMVarDone next value maybePutIndex ) -> let ( updatedModel, updatedCmd ) = update (ReadMVarMsg index value) { newRealWorld | next = Dict.insert index (TakeMVarNext next) model.next } in - case Debug.log "maybePutIndex" maybePutIndex of + case maybePutIndex of Just putIndex -> - update (PutMVarMsg (Debug.log "putIndex" putIndex)) updatedModel + update (PutMVarMsg putIndex) updatedModel |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, updatedCmd ]) Nothing -> ( updatedModel, updatedCmd ) ( newRealWorld, PutMVarWaiting next ) -> - ( { newRealWorld | next = Dict.insert (Debug.log "INDEX1" index) (PutMVarNext next) model.next }, Cmd.none ) + ( { newRealWorld | next = Dict.insert index (PutMVarNext next) model.next }, Cmd.none ) ( newRealWorld, PutMVarDone next readSubscriberIds maybeTakeIndex value ) -> - let - _ = - Debug.log "readSubscriberIds maybeTakeIndex" ( readSubscriberIds, maybeTakeIndex ) - in List.foldr (\readSubscriberId ( accModel, accCmd ) -> - update (ReadMVarMsg (Debug.log "readSubscriberId" readSubscriberId) value) accModel + update (ReadMVarMsg readSubscriberId value) accModel |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, accCmd ]) ) - (update (PutMVarMsg index) { newRealWorld | next = Dict.insert (Debug.log "INDEX2" index) (PutMVarNext next) model.next }) + (update (PutMVarMsg index) { newRealWorld | next = Dict.insert index (PutMVarNext next) model.next }) readSubscriberIds GetLineMsg index input -> @@ -527,8 +518,8 @@ update msg model = Just (DirDoesFileExistNext fn) -> update (PureMsg index (fn value)) model - nextFn -> - crash ("DirDoesFileExistMsg " ++ String.fromInt index ++ " - " ++ Debug.toString nextFn) + _ -> + crash "DirDoesFileExistMsg" DirCreateDirectoryIfMissingMsg index -> case Dict.get index model.next of @@ -836,24 +827,25 @@ type ION a | ExitWith (a -> IO a) Int | DirFindExecutable (Maybe FilePath -> IO a) FilePath | ReplGetInputLine (Maybe String -> IO a) String - | PutMVarWaiting (() -> IO a) - | PutMVarDone (() -> IO a) (List Int) (Maybe Int) Encode.Value | DirDoesFileExist (Bool -> IO a) FilePath | DirCreateDirectoryIfMissing (() -> IO a) Bool FilePath | LockFile (() -> IO a) FilePath | UnlockFile (() -> IO a) FilePath | DirGetModificationTime (Int -> IO a) FilePath - | TakeMVarWaiting (Encode.Value -> IO a) - | TakeMVarTaken (Encode.Value -> IO a) Encode.Value (Maybe Int) | DirDoesDirectoryExist (Bool -> IO a) FilePath | DirCanonicalizePath (String -> IO a) FilePath - | ReadMVar (Encode.Value -> IO a) | BinaryDecodeFileOrFail (Encode.Value -> IO a) FilePath | Write (() -> IO a) FilePath Encode.Value | DirRemoveFile (() -> IO a) FilePath | DirRemoveDirectoryRecursive (() -> IO a) FilePath | DirWithCurrentDirectory (() -> IO a) FilePath | ReplGetInputLineWithInitial (Maybe String -> IO a) String String String + | ReadMVarWaiting (Encode.Value -> IO a) + | ReadMVarDone (Encode.Value -> IO a) Encode.Value + | TakeMVarWaiting (Encode.Value -> IO a) + | TakeMVarDone (Encode.Value -> IO a) Encode.Value (Maybe Int) + | PutMVarWaiting (() -> IO a) + | PutMVarDone (() -> IO a) (List Int) (Maybe Int) Encode.Value type alias RealWorld = @@ -993,14 +985,17 @@ bind f (IO ma) = ( s1, ReplGetInputLineWithInitial next prompt left right ) -> ( s1, ReplGetInputLineWithInitial (\value -> bind f (next value)) prompt left right ) - ( s1, ReadMVar next ) -> - ( s1, ReadMVar (\value -> bind f (next value)) ) + ( s1, ReadMVarWaiting next ) -> + ( s1, ReadMVarWaiting (\value -> bind f (next value)) ) + + ( s1, ReadMVarDone next readValue ) -> + ( s1, ReadMVarDone (\value -> bind f (next value)) readValue ) ( s1, TakeMVarWaiting next ) -> ( s1, TakeMVarWaiting (\value -> bind f (next value)) ) - ( s1, TakeMVarTaken next takenValue maybePutIndex ) -> - ( s1, TakeMVarTaken (\value -> bind f (next value)) takenValue maybePutIndex ) + ( s1, TakeMVarDone next takenValue maybePutIndex ) -> + ( s1, TakeMVarDone (\value -> bind f (next value)) takenValue maybePutIndex ) ( s1, PutMVarWaiting next ) -> ( s1, PutMVarWaiting (\() -> bind f (next ())) ) diff --git a/src/Utils/Crash.elm b/src/Utils/Crash.elm index 8ec65155b..76f69679b 100644 --- a/src/Utils/Crash.elm +++ b/src/Utils/Crash.elm @@ -3,4 +3,4 @@ module Utils.Crash exposing (crash) crash : String -> a crash str = - Debug.todo str + crash str diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index 6733697ad..be2f00bde 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -140,7 +140,7 @@ import Json.Encode as Encode import Maybe.Extra as Maybe import Prelude import System.Exit as Exit -import System.IO as IO exposing (IO(..), MVarSubscriber(..)) +import System.IO as IO exposing (IO(..)) import Time import Utils.Crash exposing (crash) @@ -935,10 +935,6 @@ newMVar encoder value = newEmptyMVar |> IO.bind (\mvar -> - let - _ = - Debug.log "mvar2" mvar - in putMVar encoder mvar value |> IO.fmap (\_ -> mvar) ) @@ -952,11 +948,11 @@ readMVar decoder (MVar ref) = Just mVar -> case mVar.value of Just value -> - ( s, IO.Pure value ) + ( s, IO.ReadMVarDone IO.pure value ) Nothing -> ( { s | mVars = Array.set ref { mVar | subscribers = IO.ReadSubscriber index :: mVar.subscribers } s.mVars } - , IO.ReadMVar IO.pure + , IO.ReadMVarWaiting IO.pure ) Nothing -> @@ -1002,7 +998,7 @@ takeMVar decoder (MVar ref) = ( Nothing, subscribers, Nothing ) in ( { s | mVars = Array.set ref { mVar | subscribers = newSubscribers, value = newValue } s.mVars } - , IO.TakeMVarTaken IO.pure value maybePutIndex + , IO.TakeMVarDone IO.pure value maybePutIndex ) Nothing -> @@ -1033,7 +1029,7 @@ putMVar encoder (MVar ref) value = case mVar.value of Just _ -> ( { s | mVars = Array.set ref { mVar | subscribers = IO.PutSubscriber index (encoder value) :: mVar.subscribers } s.mVars } - , Debug.log "PutMVarWaiting" (IO.PutMVarWaiting IO.pure) + , IO.PutMVarWaiting IO.pure ) Nothing -> @@ -1070,15 +1066,11 @@ putMVar encoder (MVar ref) value = (IO.TakeSubscriber takeIndex) :: remainingSubscribers -> ( Nothing, Just takeIndex, remainingSubscribers ) - all -> - let - _ = - Debug.log "ALL!!!" all - in + _ -> ( Just encodedValue, Nothing, nonReadSubscribers ) in ( { s | mVars = Array.set ref { mVar | subscribers = subscribers, value = newValue } s.mVars } - , Debug.log "PutMVarDone" (IO.PutMVarDone IO.pure readSubscriberIds maybeTakeIndex encodedValue) + , IO.PutMVarDone IO.pure readSubscriberIds maybeTakeIndex encodedValue ) _ -> @@ -1090,10 +1082,6 @@ newEmptyMVar : IO (MVar a) newEmptyMVar = IO (\_ s -> - let - _ = - Debug.log "newEmptyMVar" (Array.length s.mVars) - in ( { s | mVars = Array.push { subscribers = [], value = Nothing } s.mVars } , IO.Pure (MVar (Array.length s.mVars)) ) From 7846c7e2e5084eb8fa687d0a6853ffb899af2f6e Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Fri, 13 Dec 2024 23:10:07 +0000 Subject: [PATCH 3/4] WIP small changes --- lib/guida.sh | 2 +- src/System/IO.elm | 38 +++++++++++++++++++------------------- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/lib/guida.sh b/lib/guida.sh index 1443cae3a..f1c2c070d 100755 --- a/lib/guida.sh +++ b/lib/guida.sh @@ -7,7 +7,7 @@ set -e js="bin/guida.js" min="bin/guida.min.js" -elm make --optimize --output=$js $@ +guida make --optimize --output=$js $@ uglifyjs $js --compress "pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe" | uglifyjs --mangle --output $min diff --git a/src/System/IO.elm b/src/System/IO.elm index 7726c76b3..e7da01146 100644 --- a/src/System/IO.elm +++ b/src/System/IO.elm @@ -505,14 +505,6 @@ update msg model = _ -> crash "ReplGetInputLineMsg" - PutMVarMsg index -> - case Dict.get index model.next of - Just (PutMVarNext fn) -> - update (PureMsg index (fn ())) model - - _ -> - crash "PutMVarMsg" - DirDoesFileExistMsg index value -> case Dict.get index model.next of Just (DirDoesFileExistNext fn) -> @@ -569,17 +561,6 @@ update msg model = _ -> crash "DirCanonicalizePathMsg" - ReadMVarMsg index value -> - case Dict.get index model.next of - Just (ReadMVarNext fn) -> - update (PureMsg index (fn value)) model - - Just (TakeMVarNext fn) -> - update (PureMsg index (fn value)) model - - _ -> - crash "ReadMVarMsg" - BinaryDecodeFileOrFailMsg index value -> case Dict.get index model.next of Just (BinaryDecodeFileOrFailNext fn) -> @@ -628,6 +609,25 @@ update msg model = _ -> crash "ReplGetInputLineWithInitialMsg" + ReadMVarMsg index value -> + case Dict.get index model.next of + Just (ReadMVarNext fn) -> + update (PureMsg index (fn value)) model + + Just (TakeMVarNext fn) -> + update (PureMsg index (fn value)) model + + _ -> + crash "ReadMVarMsg" + + PutMVarMsg index -> + case Dict.get index model.next of + Just (PutMVarNext fn) -> + update (PureMsg index (fn ())) model + + _ -> + crash "PutMVarMsg" + port sendGetLine : Int -> Cmd msg From 55275206583ec159274d3f527bdc9f7c61173235 Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Mon, 16 Dec 2024 23:08:22 +0000 Subject: [PATCH 4/4] WIP MVars --- src/System/IO.elm | 19 ++++++++++++++++++- src/Utils/Main.elm | 9 +++++---- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/src/System/IO.elm b/src/System/IO.elm index e7da01146..d73c4a426 100644 --- a/src/System/IO.elm +++ b/src/System/IO.elm @@ -185,6 +185,7 @@ type Next | DirRemoveDirectoryRecursiveNext (() -> IO ()) | DirWithCurrentDirectoryNext (() -> IO ()) | ReplGetInputLineWithInitialNext (Maybe String -> IO ()) + | NewEmptyMVarNext (Int -> IO ()) | ReadMVarNext (Encode.Value -> IO ()) | TakeMVarNext (Encode.Value -> IO ()) | PutMVarNext (() -> IO ()) @@ -220,6 +221,7 @@ type Msg | DirRemoveDirectoryRecursiveMsg Int | DirWithCurrentDirectoryMsg Int | ReplGetInputLineWithInitialMsg Int (Maybe String) + | NewEmptyMVarMsg Int Int | ReadMVarMsg Int Encode.Value | PutMVarMsg Int @@ -244,7 +246,7 @@ update msg model = update (PureMsg index (next ())) newRealWorld in update (PureMsg (Dict.size model.next) forkIO) updatedModel - |> Tuple.mapSecond (\cmd -> Cmd.batch [ updatedCmd, cmd ]) + |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, updatedCmd ]) ( newRealWorld, GetLine next ) -> ( { newRealWorld | next = Dict.insert index (GetLineNext next) model.next }, sendGetLine index ) @@ -351,6 +353,9 @@ update msg model = ( newRealWorld, ReplGetInputLineWithInitial next prompt left right ) -> ( { newRealWorld | next = Dict.insert index (ReplGetInputLineWithInitialNext next) model.next }, sendReplGetInputLineWithInitial { index = index, prompt = prompt, left = left, right = right } ) + ( newRealWorld, NewEmptyMVar next value ) -> + update (NewEmptyMVarMsg index value) { newRealWorld | next = Dict.insert index (NewEmptyMVarNext next) model.next } + ( newRealWorld, ReadMVarWaiting next ) -> ( { newRealWorld | next = Dict.insert index (ReadMVarNext next) model.next }, Cmd.none ) @@ -609,6 +614,14 @@ update msg model = _ -> crash "ReplGetInputLineWithInitialMsg" + NewEmptyMVarMsg index value -> + case Dict.get index model.next of + Just (NewEmptyMVarNext fn) -> + update (PureMsg index (fn value)) model + + _ -> + crash "NewEmptyMVarMsg" + ReadMVarMsg index value -> case Dict.get index model.next of Just (ReadMVarNext fn) -> @@ -840,6 +853,7 @@ type ION a | DirRemoveDirectoryRecursive (() -> IO a) FilePath | DirWithCurrentDirectory (() -> IO a) FilePath | ReplGetInputLineWithInitial (Maybe String -> IO a) String String String + | NewEmptyMVar (Int -> IO a) Int | ReadMVarWaiting (Encode.Value -> IO a) | ReadMVarDone (Encode.Value -> IO a) Encode.Value | TakeMVarWaiting (Encode.Value -> IO a) @@ -985,6 +999,9 @@ bind f (IO ma) = ( s1, ReplGetInputLineWithInitial next prompt left right ) -> ( s1, ReplGetInputLineWithInitial (\value -> bind f (next value)) prompt left right ) + ( s1, NewEmptyMVar next newValue ) -> + ( s1, NewEmptyMVar (\value -> bind f (next value)) newValue ) + ( s1, ReadMVarWaiting next ) -> ( s1, ReadMVarWaiting (\value -> bind f (next value)) ) diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm index be2f00bde..ed182bde0 100644 --- a/src/Utils/Main.elm +++ b/src/Utils/Main.elm @@ -951,7 +951,7 @@ readMVar decoder (MVar ref) = ( s, IO.ReadMVarDone IO.pure value ) Nothing -> - ( { s | mVars = Array.set ref { mVar | subscribers = IO.ReadSubscriber index :: mVar.subscribers } s.mVars } + ( { s | mVars = Array.set ref { mVar | subscribers = mVar.subscribers ++ [ IO.ReadSubscriber index ] } s.mVars } , IO.ReadMVarWaiting IO.pure ) @@ -1002,7 +1002,7 @@ takeMVar decoder (MVar ref) = ) Nothing -> - ( { s | mVars = Array.set ref { mVar | subscribers = IO.TakeSubscriber index :: mVar.subscribers } s.mVars } + ( { s | mVars = Array.set ref { mVar | subscribers = mVar.subscribers ++ [ IO.TakeSubscriber index ] } s.mVars } , IO.TakeMVarWaiting IO.pure ) @@ -1028,7 +1028,7 @@ putMVar encoder (MVar ref) value = Just mVar -> case mVar.value of Just _ -> - ( { s | mVars = Array.set ref { mVar | subscribers = IO.PutSubscriber index (encoder value) :: mVar.subscribers } s.mVars } + ( { s | mVars = Array.set ref { mVar | subscribers = mVar.subscribers ++ [ IO.PutSubscriber index (encoder value) ] } s.mVars } , IO.PutMVarWaiting IO.pure ) @@ -1083,9 +1083,10 @@ newEmptyMVar = IO (\_ s -> ( { s | mVars = Array.push { subscribers = [], value = Nothing } s.mVars } - , IO.Pure (MVar (Array.length s.mVars)) + , IO.NewEmptyMVar IO.pure (Array.length s.mVars) ) ) + |> IO.fmap MVar