Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -71,6 +71,7 @@ import qualified GHC.Boot.TH.Monad as TH
    71 71 
     import System.Exit
    72 72 
     import System.IO
    73 73 
     import System.IO.Error
    74 
    +import Data.Word (Word8)
    74 75
    75 76 
     -- -----------------------------------------------------------------------------
    76 77 
     -- The RPC protocol between GHC and the interactive server
    ... ... @@ -246,6 +247,11 @@ data Message a where
    246 247 
         :: RemoteRef (ResumeContext ())
    247 248 
         -> Message (EvalStatus ())
    248 249
    250 
    +  -- | User-defined request encoded as a tag/payload pair.  This is left
    251 
    +  -- uninterpreted by GHC and is meant for GHC API applications to be able to supply
    252 
    +  -- their own interpreter which understands additional commands.
    253 
    +  CustomMessage :: Word8 -> ByteString -> Message ByteString
    254 
    +
    249 255 
     deriving instance Show (Message a)
    250 256
    251 257 
     -- | Used to dynamically create a data constructor's info table at
    ... ... @@ -602,6 +608,7 @@ getMessage = do
    602 608 
           38 -> Msg <$> (ResumeSeq <$> get)
    603 609 
           39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
    604 610 
           40 -> Msg <$> (WhereFrom <$> get)
    611 
    +      41 -> Msg <$> (CustomMessage <$> get <*> get)
    605 612 
           _  -> error $ "Unknown Message code " ++ (show b)
    606 613
    607 614 
     putMessage :: Message a -> Put
    ... ... @@ -648,6 +655,7 @@ putMessage m = case m of
    648 655 
       ResumeSeq a                 -> putWord8 38 >> put a
    649 656 
       LookupSymbolInDLL dll str   -> putWord8 39 >> put dll >> put str
    650 657 
       WhereFrom a                 -> putWord8 40 >> put a
    658 
    +  CustomMessage tag payload   -> putWord8 41 >> put tag >> put payload
    651 659
    652 660 
     {-
    653 661 
     Note [Parallelize CreateBCOs serialization]

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -125,6 +125,7 @@ run m = case m of
    125 125 
       Shutdown            -> unexpectedMessage m
    126 126 
       RunTH {}            -> unexpectedMessage m
    127 127 
       RunModFinalizers {} -> unexpectedMessage m
    128 
    +  CustomMessage {}    -> unexpectedMessage m
    128 129
    129 130 
     unexpectedMessage :: Message a -> b
    130 131 
     unexpectedMessage m = error ("GHCi.Run.Run: unexpected message: " ++ show m)

  • libraries/ghci/GHCi/Server.hs
    1 1 
     {-# LANGUAGE CPP, RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
    2 2 
     module GHCi.Server
    3 
    -  ( serv
    3 
    +  ( MessageHook
    4 
    +  , CustomMessageHandler
    5 
    +  , serv
    6 
    +  , servWithCustom
    4 7 
       , defaultServer
    8 
    +  , defaultServerWithCustom
    5 9 
       )
    6 10 
     where
    7 11
    ... ... @@ -10,8 +14,8 @@ import GHCi.Run
    10 14 
     import GHCi.Signals
    11 15 
     import GHCi.TH
    12 16 
     import GHCi.Message
    13 
    -#if defined(wasm32_HOST_ARCH)
    14 17 
     import Data.ByteString (ByteString)
    18 
    +#if defined(wasm32_HOST_ARCH)
    15 19 
     import qualified Data.ByteString.Builder as B
    16 20 
     import qualified Data.ByteString.Internal as B
    17 21 
     import qualified Data.ByteString.Unsafe as B
    ... ... @@ -22,6 +26,7 @@ import GHC.Wasm.Prim
    22 26 
     #else
    23 27 
     import GHCi.Utils
    24 28 
     #endif
    29 
    +import Data.Word (Word8)
    25 30
    26 31 
     import Control.DeepSeq
    27 32 
     import Control.Exception
    ... ... @@ -36,11 +41,27 @@ import System.IO
    36 41
    37 42 
     type MessageHook = Msg -> IO Msg
    38 43
    44 
    +-- | How to interpret the 'CustomCommand'.
    45 
    +type CustomMessageHandler = Word8 -> ByteString -> IO (Maybe ByteString)
    46 
    +
    47 
    +noCustomHandler :: CustomMessageHandler
    48 
    +noCustomHandler _ _ = return Nothing
    49 
    +
    39 50 
     trace :: String -> IO ()
    40 51 
     trace s = getProgName >>= \name -> hPrintf stderr "[%20s] %s\n" name s
    41 52
    42 53 
     serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
    43 
    -serv verbose hook pipe restore = loop
    54 
    +serv verbose hook pipe restore =
    55 
    +  servWithCustom verbose hook pipe restore noCustomHandler
    56 
    +
    57 
    +servWithCustom
    58 
    +  :: Bool
    59 
    +  -> MessageHook
    60 
    +  -> Pipe
    61 
    +  -> (forall a .IO a -> IO a)
    62 
    +  -> CustomMessageHandler
    63 
    +  -> IO ()
    64 
    +servWithCustom verbose hook pipe restore customHandler = loop
    44 65 
      where
    45 66 
       loop = do
    46 67 
         when verbose $ trace "reading pipe..."
    ... ... @@ -50,6 +71,7 @@ serv verbose hook pipe restore = loop
    50 71
    51 72 
         when verbose $ trace ("msg: " ++ (show msg))
    52 73 
         case msg of
    74 
    +      CustomMessage tag payload -> handleCustom tag payload
    53 75 
           Shutdown -> return ()
    54 76 
           RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
    55 77 
           RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
    ... ... @@ -61,6 +83,13 @@ serv verbose hook pipe restore = loop
    61 83 
         writePipe pipe (put r)
    62 84 
         loop
    63 85
    86 
    +  handleCustom tag payload = do
    87 
    +    mresp <- customHandler tag payload
    88 
    +    case mresp of
    89 
    +      Just resp -> reply resp
    90 
    +      Nothing ->
    91 
    +        error $ "GHCi.Server: unhandled CustomMessage with tag " ++ show tag
    92 
    +
    64 93 
       -- Run some TH code, which may interact with GHC by sending
    65 94 
       -- THMessage requests, and then finally send RunTHDone followed by a
    66 95 
       -- QResult.  For an overview of how TH works with Remote GHCi, see
    ... ... @@ -109,12 +138,24 @@ serv verbose hook pipe restore = loop
    109 138 
     -- | Default server
    110 139 
     #if defined(wasm32_HOST_ARCH)
    111 140 
     defaultServer :: Callback (JSVal -> IO ()) -> Callback (IO JSUint8Array) -> Callback (JSUint8Array -> IO ()) -> IO ()
    112 
    -defaultServer cb_sig cb_recv cb_send = do
    141 
    +defaultServer cb_sig cb_recv cb_send =
    142 
    +  defaultServerWithCustom cb_sig cb_recv cb_send noCustomHandler
    143 
    +
    144 
    +defaultServerWithCustom
    145 
    +  :: Callback (JSVal -> IO ())
    146 
    +  -> Callback (IO JSUint8Array)
    147 
    +  -> Callback (JSUint8Array -> IO ())
    148 
    +  -> CustomMessageHandler
    149 
    +  -> IO ()
    150 
    +defaultServerWithCustom cb_sig cb_recv cb_send customHandler = do
    113 151 
       args <- getArgs
    114 152 
       let rest = args
    115 153 
     #else
    116 154 
     defaultServer :: IO ()
    117 
    -defaultServer = do
    155 
    +defaultServer = defaultServerWithCustom noCustomHandler
    156 
    +
    157 
    +defaultServerWithCustom :: CustomMessageHandler -> IO ()
    158 
    +defaultServerWithCustom customHandler = do
    118 159 
       args <- getArgs
    119 160 
       (outh, inh, rest) <-
    120 161 
           case args of
    ... ... @@ -152,7 +193,7 @@ defaultServer = do
    152 193 
           putStrLn "Waiting 3s"
    153 194 
         threadDelay 3000000
    154 195
    155 
    -  uninterruptibleMask $ serv verbose hook pipe
    196 
    +  uninterruptibleMask $ \restore -> servWithCustom verbose hook pipe restore customHandler
    156 197
    157 198 
       where hook = return -- empty hook
    158 199 
         -- we cannot allow any async exceptions while communicating, because

  • testsuite/tests/ghci/custom-external-interpreter-commands/Main.hs
    1 
    +{-# LANGUAGE OverloadedStrings, GADTs, TypeAbstractions #-}
    2 
    +module Main (main) where
    3 
    +
    4 
    +import qualified Data.Binary as Bin
    5 
    +import qualified Data.ByteString as BS
    6 
    +import qualified Data.ByteString.Lazy as BL
    7 
    +import Control.Exception (bracket)
    8 
    +import Control.Monad (void)
    9 
    +import Data.Word (Word8)
    10 
    +import GHCi.Message
    11 
    +  ( Message(..)
    12 
    +  , mkPipeFromHandles
    13 
    +  , remoteCall
    14 
    +  , Pipe
    15 
    +  )
    16 
    +import GHCi.Server
    17 
    +  ( CustomMessageHandler
    18 
    +  , defaultServerWithCustom
    19 
    +  )
    20 
    +import System.Environment
    21 
    +  ( getArgs
    22 
    +  , getExecutablePath
    23 
    +  , getProgName
    24 
    +  , withArgs
    25 
    +  )
    26 
    +import System.Exit (exitFailure)
    27 
    +import System.IO
    28 
    +  ( Handle
    29 
    +  , BufferMode(..)
    30 
    +  , hSetBuffering
    31 
    +  , hSetBinaryMode
    32 
    +  , hClose
    33 
    +  , hPutStrLn
    34 
    +  , stderr
    35 
    +  )
    36 
    +import System.Posix.IO
    37 
    +  ( createPipe
    38 
    +  , fdToHandle
    39 
    +  , setFdOption
    40 
    +  , FdOption(CloseOnExec)
    41 
    +  )
    42 
    +import System.Process
    43 
    +  ( createProcess
    44 
    +  , proc
    45 
    +  , std_in
    46 
    +  , std_out
    47 
    +  , std_err
    48 
    +  , StdStream(Inherit)
    49 
    +  , terminateProcess
    50 
    +  , waitForProcess
    51 
    +  , ProcessHandle
    52 
    +  )
    53 
    +import Text.Read (readMaybe)
    54 
    +
    55 
    +--------------------------------------------------------------------------------
    56 
    +-- Shared request/response definitions and helpers
    57 
    +
    58 
    +data ClientCommand a where
    59 
    +  SquareCommand :: Int -> ClientCommand Int
    60 
    +  MulCommand :: Int -> Int -> ClientCommand Int
    61 
    +
    62 
    +deriving instance (Show (ClientCommand a))
    63 
    +
    64 
    +data Some c f where
    65 
    +  Some :: c a => f a -> Some c f
    66 
    +
    67 
    +
    68 
    +instance Bin.Binary (Some Bin.Binary ClientCommand) where
    69 
    +  put (Some i) =
    70 
    +    case i of
    71 
    +      SquareCommand n -> Bin.put (0 :: Word8) >> Bin.put n
    72 
    +      MulCommand m n -> Bin.put (1 :: Word8) >> Bin.put m >> Bin.put n
    73 
    +
    74 
    +  get = do
    75 
    +    (tag :: Word8) <- Bin.get
    76 
    +    fmap Some $ case tag of
    77 
    +      0 -> SquareCommand <$> Bin.get
    78 
    +      1 -> MulCommand <$> Bin.get <*> Bin.get
    79 
    +
    80 
    +
    81 
    +customTag :: Word8
    82 
    +customTag = 0x42
    83 
    +
    84 
    +encodeLazy :: Bin.Binary a => a -> BS.ByteString
    85 
    +encodeLazy = BL.toStrict . Bin.encode
    86 
    +
    87 
    +decodeLazy :: Bin.Binary a => BS.ByteString -> Either String a
    88 
    +decodeLazy bs =
    89 
    +  case Bin.decodeOrFail (BL.fromStrict bs) of
    90 
    +    Left (_, _, err) -> Left err
    91 
    +    Right (_, _, a)  -> Right a
    92 
    +
    93 
    +--------------------------------------------------------------------------------
    94 
    +-- Mode selection
    95 
    +
    96 
    +data Mode
    97 
    +  = RunClient Int
    98 
    +  | RunServer [String] -- forwarded to GHCi.Server
    99 
    +
    100 
    +defaultInput :: Int
    101 
    +defaultInput = 12
    102 
    +
    103 
    +parseMode :: [String] -> Either String Mode
    104 
    +parseMode [] = Right (RunClient defaultInput)
    105 
    +parseMode ["client"] = Right (RunClient defaultInput)
    106 
    +parseMode ["client", nStr] =
    107 
    +  case readMaybe nStr of
    108 
    +    Just n -> Right (RunClient n)
    109 
    +    Nothing -> Left $ "Unable to parse integer argument: " ++ nStr
    110 
    +parseMode ("client":_) = Left "Too many arguments for client mode."
    111 
    +parseMode ("server":rest) = Right (RunServer rest)
    112 
    +parseMode args = Left "Unknown mode, use client/server"
    113 
    +
    114 
    +usage :: IO ()
    115 
    +usage = do
    116 
    +  prog <- getProgName
    117 
    +  putStrLn $ unlines
    118 
    +    [ "Usage:"
    119 
    +    , "  " ++ prog ++ " [client [n]]   Run the client and square n (default 12)."
    120 
    +    , "  " ++ prog ++ " server <write-fd> <read-fd>  Run as an iserv process."
    121 
    +    ]
    122 
    +
    123 
    +--------------------------------------------------------------------------------
    124 
    +-- Client/server drivers
    125 
    +
    126 
    +main :: IO ()
    127 
    +main = do
    128 
    +  args <- getArgs
    129 
    +  case parseMode args of
    130 
    +    Left err -> do
    131 
    +      hPutStrLn stderr err
    132 
    +      usage
    133 
    +      exitFailure
    134 
    +    Right (RunClient n) -> runClient n
    135 
    +    Right (RunServer serverArgs) ->
    136 
    +      withArgs serverArgs (defaultServerWithCustom (customHandler handleClientCommand))
    137 
    +
    138 
    +handleClientCommand :: ClientCommand a -> IO a
    139 
    +handleClientCommand (SquareCommand n) = pure $ n * n
    140 
    +handleClientCommand (MulCommand n m)  = pure $ n * m
    141 
    +
    142 
    +
    143 
    +customMessage :: (Show a, Bin.Binary a) => Pipe -> ClientCommand a -> IO a
    144 
    +customMessage pipe c = do
    145 
    +  let payload = encodeLazy (Some @Bin.Binary c)
    146 
    +  putStrLn $ "Sending: " ++ show c
    147 
    +  respBytes <- remoteCall pipe (CustomMessage customTag payload)
    148 
    +  case decodeLazy respBytes of
    149 
    +    Left err -> error $ "Decode error: " ++ err
    150 
    +    Right res -> pure res
    151 
    +
    152 
    +
    153 
    +runClient :: Int -> IO ()
    154 
    +runClient input = do
    155 
    +  serverExe <- getExecutablePath
    156 
    +  withServer serverExe $ \hFromServer hToServer -> do
    157 
    +    pipe <- mkPipeFromHandles hFromServer hToServer
    158 
    +    res  <- customMessage pipe (SquareCommand input)
    159 
    +    putStrLn $ "Square returned: " ++ show res
    160 
    +    res2  <- customMessage pipe (MulCommand 2 res)
    161 
    +    putStrLn $ "Mul returned: " ++ show res2
    162 
    +
    163 
    +withServer :: FilePath -> (Handle -> Handle -> IO a) -> IO a
    164 
    +withServer serverExe action = do
    165 
    +  (ghcRead, serverWrite) <- createPipe
    166 
    +  (serverRead, ghcWrite) <- createPipe
    167 
    +  mapM_ (\h -> setFdOption h CloseOnExec False) [serverWrite, serverRead]
    168 
    +  let args = ["server", show serverWrite, show serverRead]
    169 
    +  (_, _, _, ph) <- createProcess (proc serverExe args)
    170 
    +    { std_in  = Inherit
    171 
    +    , std_out = Inherit
    172 
    +    , std_err = Inherit
    173 
    +    }
    174 
    +  bracket (mkHandles ghcRead ghcWrite)
    175 
    +          (\(hFromServer, hToServer) -> do
    176 
    +             hClose hFromServer
    177 
    +             hClose hToServer
    178 
    +             terminateProcess ph
    179 
    +             void (waitForProcess ph))
    180 
    +          (\(hFromServer, hToServer) -> action hFromServer hToServer)
    181 
    +  where
    182 
    +    mkHandles r w = do
    183 
    +      hR <- fdToHandle r
    184 
    +      hW <- fdToHandle w
    185 
    +      mapM_ (`hSetBuffering` NoBuffering) [hR, hW]
    186 
    +      mapM_ (`hSetBinaryMode` True) [hR, hW]
    187 
    +      pure (hR, hW)
    188 
    +
    189 
    +--------------------------------------------------------------------------------
    190 
    +-- Custom handler
    191 
    +
    192 
    +customHandler :: (Bin.Binary (Some Bin.Binary f)) => (forall a . f a -> IO a) -> CustomMessageHandler
    193 
    +customHandler handler tag payload
    194 
    +  | tag == customTag =
    195 
    +      case decodeLazy payload of
    196 
    +        Left err -> do
    197 
    +          hPutStrLn stderr $ "Custom handler decode error: " ++ err
    198 
    +          pure Nothing
    199 
    +        Right (Some @Bin.Binary r) -> do
    200 
    +          res <- handler r
    201 
    +          pure . Just $ encodeLazy res
    202 
    +  | otherwise = pure Nothing

  • testsuite/tests/ghci/custom-external-interpreter-commands/all.T
    1 
    +test('custom-external-interpreter-commands',
    2 
    +     [ extra_files(['Main.hs'])
    3 
    +     , windows_skip
    4 
    +     , when(config.cross, skip)
    5 
    +     , req_process
    6 
    +     , req_interp
    7 
    +     , omit_ways(prof_ways)
    8 
    +     ],
    9 
    +     multimod_compile_and_run,
    10 
    +     ['Main.hs', '-package ghci'])

  • testsuite/tests/ghci/custom-external-interpreter-commands/custom-external-interpreter-commands.stdout
    1 
    +Sending: SquareCommand 12
    2 
    +Square returned: 144
    3 
    +Sending: MulCommand 2 144
    4 
    +Mul returned: 288

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help