diff --git a/bin/index.js b/bin/index.js index e34f83559..50df07f1b 100755 --- a/bin/index.js +++ b/bin/index.js @@ -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/src/Builder/File.elm b/src/Builder/File.elm index 7ac13d8c9..4a4ec774c 100644 --- a/src/Builder/File.elm +++ b/src/Builder/File.elm @@ -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 )) 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..d73c4a426 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 @@ -229,9 +230,9 @@ update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = 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 +243,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 ]) + |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, updatedCmd ]) ( 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 +294,101 @@ 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 } ) + ( { 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, NewEmptyMVar next ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (NewEmptyMVarNext next) model.next }, sendNewEmptyMVar index ) + ( newRealWorld, NewEmptyMVar next value ) -> + update (NewEmptyMVarMsg index value) { newRealWorld | next = Dict.insert index (NewEmptyMVarNext next) model.next } - ( newRealWorld, ReadMVar next id ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (ReadMVarNext next) model.next }, sendReadMVar { index = index, id = id } ) + ( newRealWorld, ReadMVarWaiting next ) -> + ( { newRealWorld | next = Dict.insert index (ReadMVarNext next) model.next }, Cmd.none ) - ( newRealWorld, TakeMVar next id ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (TakeMVarNext next) model.next }, sendTakeMVar { index = index, id = id } ) + ( newRealWorld, ReadMVarDone next value ) -> + update (ReadMVarMsg index value) { newRealWorld | next = Dict.insert index (ReadMVarNext next) model.next } - ( newRealWorld, PutMVar next id value ) -> - ( { model | realWorld = newRealWorld, next = Dict.insert index (PutMVarNext next) model.next }, sendPutMVar { index = index, id = id, value = value } ) + ( newRealWorld, TakeMVarWaiting next ) -> + ( { newRealWorld | next = Dict.insert index (TakeMVarNext next) model.next }, Cmd.none ) + + ( newRealWorld, TakeMVarDone next value maybePutIndex ) -> + let + ( updatedModel, updatedCmd ) = + update (ReadMVarMsg index value) { newRealWorld | next = Dict.insert index (TakeMVarNext next) model.next } + in + case maybePutIndex of + Just putIndex -> + update (PutMVarMsg putIndex) updatedModel + |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, updatedCmd ]) + + Nothing -> + ( updatedModel, updatedCmd ) + + ( newRealWorld, PutMVarWaiting next ) -> + ( { newRealWorld | next = Dict.insert index (PutMVarNext next) model.next }, Cmd.none ) + + ( newRealWorld, PutMVarDone next readSubscriberIds maybeTakeIndex value ) -> + List.foldr + (\readSubscriberId ( accModel, accCmd ) -> + update (ReadMVarMsg readSubscriberId value) accModel + |> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, accCmd ]) + ) + (update (PutMVarMsg index) { newRealWorld | next = Dict.insert index (PutMVarNext next) model.next }) + readSubscriberIds GetLineMsg index input -> case Dict.get index model.next of @@ -468,14 +494,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) -> @@ -492,14 +510,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) -> @@ -556,17 +566,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) -> @@ -615,6 +614,33 @@ 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) -> + 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 @@ -788,36 +814,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,25 +838,28 @@ 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 | 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 | DirDoesDirectoryExist (Bool -> IO a) FilePath | DirCanonicalizePath (String -> IO a) FilePath - | ReadMVar (Encode.Value -> IO a) Int | 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 + | NewEmptyMVar (Int -> IO a) Int + | 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 = @@ -865,12 +869,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 +904,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 +999,30 @@ 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, NewEmptyMVar next newValue ) -> + ( s1, NewEmptyMVar (\value -> bind f (next value)) newValue ) + + ( 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, ReadMVar next path ) -> - ( s1, ReadMVar (\value -> bind f (next value)) path ) + ( s1, TakeMVarDone next takenValue maybePutIndex ) -> + ( s1, TakeMVarDone (\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 +1059,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 +1076,7 @@ type IOMode hClose : Handle -> IO () hClose handle = - IO (\s -> ( s, HClose pure handle )) + IO (\_ s -> ( s, HClose pure handle )) @@ -1058,7 +1085,7 @@ hClose handle = hFileSize : Handle -> IO Int hFileSize handle = - IO (\s -> ( s, HFileSize pure handle )) + IO (\_ s -> ( s, HFileSize pure handle )) @@ -1067,7 +1094,7 @@ hFileSize handle = hFlush : Handle -> IO () hFlush handle = - IO (\s -> ( s, HFlush pure handle )) + IO (\_ s -> ( s, HFlush pure handle )) @@ -1085,7 +1112,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 +1136,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/Main.elm b/src/Utils/Main.elm index 9cbcffbb0..ed182bde0 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 @@ -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 )) @@ -941,7 +942,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.ReadMVarDone IO.pure value ) + + Nothing -> + ( { s | mVars = Array.set ref { mVar | subscribers = mVar.subscribers ++ [ IO.ReadSubscriber index ] } s.mVars } + , IO.ReadMVarWaiting IO.pure + ) + + Nothing -> + crash "Utils.Main.readMVar: invalid ref" + ) |> IO.fmap (\encodedValue -> case Decode.decodeValue decoder encodedValue of @@ -966,7 +982,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.TakeMVarDone IO.pure value maybePutIndex + ) + + Nothing -> + ( { s | mVars = Array.set ref { mVar | subscribers = mVar.subscribers ++ [ IO.TakeSubscriber index ] } s.mVars } + , IO.TakeMVarWaiting IO.pure + ) + + Nothing -> + crash "Utils.Main.takeMVar: invalid ref" + ) |> IO.fmap (\encodedValue -> case Decode.decodeValue decoder encodedValue of @@ -980,12 +1022,70 @@ 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 = mVar.subscribers ++ [ IO.PutSubscriber index (encoder value) ] } s.mVars } + , 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 ) + + _ -> + ( Just encodedValue, Nothing, nonReadSubscribers ) + in + ( { s | mVars = Array.set ref { mVar | subscribers = subscribers, value = newValue } s.mVars } + , 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 + (\_ s -> + ( { s | mVars = Array.push { subscribers = [], value = Nothing } s.mVars } + , IO.NewEmptyMVar IO.pure (Array.length s.mVars) + ) + ) |> IO.fmap MVar @@ -1055,7 +1155,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 +1164,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 +1173,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 +1218,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 ))