diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index d50279f1ad..9bfe9c9a30 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -107,6 +107,11 @@ constructorId ref name = do (_, _, dd) <- find (\(_, r, _) -> Reference.DerivedId r == ref) builtinDataDecls fmap fromIntegral . elemIndex name $ DD.constructorNames dd +effectId :: Reference -> Text -> Maybe ConstructorId +effectId ref name = do + (_, _, ed) <- find (\(_, r, _) -> Reference.DerivedId r == ref) builtinEffectDecls + fmap fromIntegral . elemIndex name . DD.constructorNames $ DD.toDataDecl ed + noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId seqViewEmpty, seqViewElem :: ConstructorId @@ -164,8 +169,13 @@ seekModeAbsoluteId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.Ab seekModeRelativeId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.RelativeSeek" seekModeEndId = Maybe.fromJust $ constructorId seekModeRef "io2.SeekMode.SeekFromEnd" +stdInId, stdOutId, stdErrId :: ConstructorId +stdInId = Maybe.fromJust $ constructorId stdHandleRef "io2.StdHandle.StdIn" +stdOutId = Maybe.fromJust $ constructorId stdHandleRef "io2.StdHandle.StdOut" +stdErrId = Maybe.fromJust $ constructorId stdHandleRef "io2.StdHandle.StdErr" + exceptionRaiseId :: ConstructorId -exceptionRaiseId = Maybe.fromJust $ constructorId exceptionRef "Exception.raise" +exceptionRaiseId = Maybe.fromJust $ effectId exceptionRef "Exception.raise" okConstructorReferent, failConstructorReferent :: Referent.Referent okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 67a4d26824..cf3e0db295 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -1112,7 +1112,7 @@ declareUdpForeigns = do declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign Tracked 1 IO_openFile_impl_v3 + declareForeign Tracked 2 IO_openFile_impl_v3 declareForeign Tracked 1 IO_closeFile_impl_v3 declareForeign Tracked 1 IO_isFileEOF_impl_v3 diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index be97b6fbc1..1cbd9305d4 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -214,13 +214,8 @@ foreignCallHelper = \case IO_UDP_ListenSocket_sendTo_impl_v1 -> mkForeignIOF $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> UDP.sendTo socket (Bytes.toArray bytes) addr - IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> + IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, mode :: IOMode) -> let fname = Util.Text.toString fnameText - mode = case n of - 0 -> ReadMode - 1 -> WriteMode - 2 -> AppendMode - _ -> ReadWriteMode in openFile fname mode IO_closeFile_impl_v3 -> mkForeignIOF hClose IO_isFileEOF_impl_v3 -> mkForeignIOF hIsEOF @@ -336,11 +331,10 @@ foreignCallHelper = \case IO_kill_impl_v3 -> mkForeignIOF killThread IO_delay_impl_v3 -> mkForeignIOF customDelay IO_stdHandle -> mkForeign $ - \(n :: Int) -> case n of - 0 -> pure SYS.stdin - 1 -> pure SYS.stdout - 2 -> pure SYS.stderr - _ -> die "IO.stdHandle: invalid input." + \case + StdIn -> pure SYS.stdin + StdOut -> pure SYS.stdout + StdErr -> pure SYS.stderr IO_process_call -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> withCreateProcess (proc exe args) $ \_ _ _ p -> @@ -1757,8 +1751,8 @@ decodeBufferMode (Enum _ t) | t == noBufTag = pure NoBuffering | t == lineBufTag = pure LineBuffering | t == blockBufTag = pure $ BlockBuffering Nothing -decodeBufferMode (Data1 _ t (IntVal i)) - | t == sizedBlockBufTag = pure . BlockBuffering $ Just i +decodeBufferMode (Data1 _ t (NatVal i)) + | t == sizedBlockBufTag = pure . BlockBuffering $ Just (fromIntegral i) decodeBufferMode c = foreignConventionError "BufferMode" (BoxedVal c) encodeBufferMode :: BufferMode -> Closure @@ -1837,6 +1831,34 @@ instance ForeignConvention SeekMode where readAtIndex stk i = bpeekOff stk i >>= decodeSeekMode writeBack stk sm = bpoke stk (encodeSeekMode sm) +data StdHnd = StdIn | StdOut | StdErr + +decodeStdHnd :: Closure -> IO StdHnd +decodeStdHnd (Enum _ t) + | t == stdInTag = pure StdIn + | t == stdOutTag = pure StdOut + | t == stdErrTag = pure StdErr +decodeStdHnd c = foreignConventionError "StdHandle" (BoxedVal c) + +encodeStdHnd :: StdHnd -> Closure +encodeStdHnd StdIn = std'in +encodeStdHnd StdOut = std'out +encodeStdHnd StdErr = std'err + +std'in, std'out, std'err :: Closure +std'in = Enum Ty.stdHandleRef stdInTag +std'out = Enum Ty.stdHandleRef stdOutTag +std'err = Enum Ty.stdHandleRef stdErrTag + +instance ForeignConvention StdHnd where + decodeVal (BoxedVal c) = decodeStdHnd c + decodeVal v = foreignConventionError "StdHandle" v + + encodeVal = BoxedVal . encodeStdHnd + + readAtIndex stk i = bpeekOff stk i >>= decodeStdHnd + writeBack stk = bpoke stk . encodeStdHnd + -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. -- instance {-# OVERLAPPING #-} ForeignConvention [Val] where diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs index d94c73b399..ea8a9236d4 100644 --- a/unison-runtime/src/Unison/Runtime/TypeTags.hs +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -33,6 +33,9 @@ module Unison.Runtime.TypeTags seekEndTag, exceptionTag, exceptionRaiseTag, + stdInTag, + stdOutTag, + stdErrTag, ) where @@ -204,6 +207,15 @@ seekAbsoluteTag, seekRelativeTag, seekEndTag :: PackedTag Ty.seekModeEndId ] = (at, rt, et) | otherwise = error "internal error: seek mode tags" +stdInTag, stdOutTag, stdErrTag :: PackedTag +(stdInTag, stdOutTag, stdErrTag) + | [it, ot, et] <- + mkTags "standard handle tags" Ty.stdHandleRef + [ Ty.stdInId, + Ty.stdOutId, + Ty.stdErrId ] = (it, ot, et) + | otherwise = error "internal error: standard handle tags" + exceptionTag :: Word64 exceptionRaiseTag :: PackedTag (exceptionTag, exceptionRaiseTag)