packages feed

sarsi 0.0.4.0 → 0.0.5.1

raw patch · 27 files changed

+1089/−464 lines, 27 filesdep +ansi-terminaldep +msgpackdep −data-msgpackdep ~asyncdep ~basedep ~bytestringnew-component:exe:srs

Dependencies added: ansi-terminal, msgpack

Dependencies removed: data-msgpack

Dependency ranges changed: async, base, bytestring, containers, cryptonite, directory, fsnotify, machines, machines-binary, machines-io, machines-process, network, process, sarsi, stm, vector

Files

+ exe/srs.hs view
@@ -0,0 +1,48 @@+module Main where++import Control.Concurrent.Async (async, wait)+import qualified Data.ByteString as ByteString+import qualified Data.List as List+import Data.Machine (Y (Z), auto, autoM, awaits, repeatedly, runT_, wye, yield, (<~))+import Sarsi.Processor (processAny)+import Sarsi.Tools.Pipe (pipeFrom)+import System.Environment (getArgs)+import System.Exit (exitWith)+import System.IO (stderr, stdout)+import System.IO.Machine (byLine, sinkHandleWith, sourceHandle, sourceHandleWith)+import System.Process++main :: IO ()+main = do+  args <- getArgs+  (dispatchErrRead, dispatchErrWrite) <- createPipe+  (dispatchOutRead, dispatchOutWrite) <- createPipe+  (Nothing, Just hout, Just herr, hprocess) <- createProcess $ cp (concat $ List.intersperse " " args)+  conveyorErr <- conveyorRun stderr herr dispatchErrWrite+  conveyorOut <- conveyorRun stdout hout dispatchOutWrite+  let sourceErr = sourceHandle byLine dispatchErrRead+  let sourceOut = sourceHandle byLine dispatchOutRead+  let process = processAny+  worker <- async $ pipeFrom "any" process $ (auto merge) <~ wye sourceErr sourceOut slurp+  wait conveyorErr+  wait conveyorOut+  wait worker+  ec <- waitForProcess hprocess+  exitWith ec+  where+    cp cmd =+      (proc "script" ["-qec", cmd, "/dev/null"])+        { delegate_ctlc = True,+          std_in = Inherit,+          std_out = CreatePipe,+          std_err = CreatePipe+        }+    conveyorRun hOutput hInput hDispatchWrite =+      async . runT_ $+        (sinkHandleWith ByteString.hPut hOutput) <~ autoM (\xs -> ByteString.hPut hDispatchWrite xs >> return xs)+          <~ (sourceHandleWith (\h -> ByteString.hGetNonBlocking h 1) hInput)+    merge (Right x) = x+    merge (Left x) = x+    slurp = repeatedly $ do+      res <- awaits Z+      yield res
− sarsi-hs/Main.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Main where--import Codec.GHC.Log (messageParser)-import Codec.Sarsi.GHC (fromGHCLog)-import Data.Attoparsec.Text.Machine (streamParser)-import Data.Machine ((<~), asParts, auto)-import Sarsi.Tools.Shell (mainShell)--main :: IO ()-main = mainShell "haskell" (asParts <~ auto unpack <~ streamParser messageParser)-  where-    unpack (Right msg) = [fromGHCLog msg]-    unpack (Left _)    = []
sarsi-nvim/Data/MessagePack/RPC.hs view
@@ -1,28 +1,28 @@ module Data.MessagePack.RPC where  import Data.Binary (Get, Put, get, getWord8, put)-import Data.Int (Int64) import Data.MessagePack (Object(..)) import Data.Text (Text)  import qualified Data.MessagePack as MP+import qualified Data.Vector as Vector  data Answer = Success Object | Error Object   deriving Show  data Request = Request-  { requestMessageID  :: Int64+  { requestMessageID  :: Int   , requestMethod     :: Text   , requestParams     :: [Object] }   deriving Show  putRequest :: Request -> Put putRequest (Request msgID method params) =-  MP.putArray id [MP.putInt 0, MP.putInt msgID, MP.putStr method, MP.putArray put params]+  MP.putArray id $ Vector.fromList [MP.putInt 0, MP.putInt msgID, MP.putStr method, MP.putArray put $ Vector.fromList params]  data Message   = Response-    { responseMessageID :: Int64+    { responseMessageID :: Int     , responseAnswer    :: Answer }   | Notification     { notificationMethod :: Text@@ -45,5 +45,5 @@     2 -> do       method <- MP.getStr       (ObjectArray params) <- get-      return $ Notification method params+      return $ Notification method (Vector.toList params)     _ -> fail "unsupported message type"
sarsi-nvim/Main.hs view
@@ -1,62 +1,297 @@ module Main where -import Codec.Sarsi (Event(..), Level(..), Location(..), Message(..))-import Data.Machine (ProcessT, (<~), asParts, final, scan, sinkPart_, runT)-import Data.MessagePack.Object (Object(..))-import NVIM.Client (Command(..), runCommand)-import Sarsi (getBroker, getTopic, title)+import Codec.Sarsi (Event (..), Level (..), Location (..), Message (..))+import Control.Concurrent.Async (async, cancel)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TBQueue (newTBQueue, readTBQueue)+import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVar, readTVar, readTVarIO, stateTVar, writeTVar)+import Control.Monad (when)+import Data.Machine (ProcessT, asParts, auto, autoM, final, runT, runT_, scan, sinkPart_, (<~))+import Data.Machine.Fanout (fanout)+import Data.MessagePack (Object (..))+import qualified Data.MessagePack.RPC as RPC+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import NVIM.Client (CommandQueue, ask', mkConnection, send)+import NVIM.Command (Command (..))+import NVIM.QuickFix (toQuickFix)+import Sarsi (Topic (..), getBroker, getTopic, title) import Sarsi.Consumer (consumeOrWait)-import System.IO (BufferMode(NoBuffering), hSetBuffering, stdin, stdout)-import System.IO.Machine (sinkIO)+import System.Environment (getArgs)+import System.Exit (ExitCode (..), exitWith)+import System.IO (Handle, IOMode (WriteMode))+import qualified System.IO as IO+import System.IO.Machine (sinkIO, sourceIO) -import qualified Data.Text as Text+data BuildStatus = Starting | Building | Done+  deriving (Show, Eq) +data PluginAction = Focus | Next | Previous+  deriving (Bounded, Show, Enum, Eq, Ord, Read)++pluginActions :: [PluginAction]+pluginActions = [minBound ..]++data PluginState = PluginState+  { buildStatus :: BuildStatus,+    buildErrors :: Vector (Location, [Text]),+    buildWarnings :: Vector (Location, [Text]),+    focus :: Maybe (Level, Int),+    buffer :: Object,+    window :: Maybe Object+  }+  deriving (Show)+ echo :: String -> Command-echo str = VimCommand [ObjectStr . Text.pack $ concat ["echo \"", str, "\""]]+echo str = NvimCommand [ObjectStr . Text.pack $ concat ["echo \"", str, "\""]]  echom :: String -> Command-echom str = VimCommand [ObjectStr . Text.pack $ concat ["echom \"", title, ": ", str, "\""]]+echom str = NvimCommand [ObjectStr . Text.pack $ concat ["echom \"", title, ": ", str, "\""]] -setqflist :: String -> [Object] -> Command-setqflist action items = VimCallFunction (Text.pack "setqflist") [ObjectArray items, ObjectStr $ Text.pack action]+jumpTo :: Location -> [Command]+jumpTo loc =+  (\x -> NvimCommand [ObjectStr . Text.pack $ x])+    <$> [ concat ["drop +", show $ line loc, " ", Text.unpack $ filePath loc],+          concat ["call cursor(", show $ line loc, ", ", show $ column loc, ")"],+          "normal zz"+        ] -setqflistEmpty :: Command-setqflistEmpty = setqflist "r" []+openLogFile :: Topic -> IO Handle+openLogFile (Topic _ fp) = IO.openFile (concat [fp, "-nvim.log"]) WriteMode --- TODO Sanitize text description by escaping special characters-mkQuickFix :: Message -> Object-mkQuickFix (Message (Location fp col ln) lvl txts) = ObjectMap $-  [ (ObjectStr $ Text.pack "filename", ObjectStr fp)-  , (ObjectStr $ Text.pack "lnum", ObjectInt ln)-  , (ObjectStr $ Text.pack "col", ObjectInt col)-  , (ObjectStr $ Text.pack "type", ObjectStr . Text.pack $ tpe lvl)-  , (ObjectStr $ Text.pack "text", ObjectStr $ Text.unlines txts) ]-    where-      tpe Error   = "E"-      tpe Warning = "W"+parseAction :: (Text, [Object]) -> PluginAction+parseAction (m, _) = read $ Text.unpack m -convert :: Int -> Event -> (Int, [Command])-convert _ e@(Start _)     = (0, [echom $ show e])-convert i e@(Finish _ _)  = (0, (echom $ show e) : (if i == 0 then [setqflistEmpty] else []))-convert i (Notify msg@(Message loc lvl _))  = (i + 1, xs) where-  xs =-    [ setqflist (if i == 0 then "r" else "a") [mkQuickFix msg]-    , echo $ concat [show loc, " ", show lvl] ]+parseArgs :: [String] -> Either String Bool+parseArgs [] = Right False+parseArgs ["--log"] = Right True+parseArgs _ = Left "usage: [--log]" +pluginStateInit :: Object -> PluginState+pluginStateInit b = PluginState Done Vector.empty Vector.empty Nothing b Nothing++putLogLn :: Maybe Handle -> String -> IO ()+putLogLn Nothing _ = return ()+putLogLn (Just h) s = IO.hPutStrLn h s >> IO.hFlush h++registerActions :: [Command]+registerActions =+  (\x -> NvimCommand [ObjectStr . Text.pack $ concat ["command! Sarsi", x, " call rpcnotify(g:sarsi, '", x, "')"]])+    <$> show+    <$> pluginActions++update :: Monoid a => Maybe Handle -> CommandQueue -> TVar PluginState -> Event -> IO a+update h q s' e = do+  display e+  case e of+    (Start _) -> updateState (\s -> s {buildStatus = Starting})+    (Finish _ _) -> do+      emptyErrors <-+        atomically $+          stateTVar+            s'+            ( \s -> case buildStatus s of+                Building -> (Vector.null $ buildErrors s, s {buildStatus = Done})+                _ -> (True, s {buildStatus = Done, buildErrors = Vector.empty, buildWarnings = Vector.empty})+            )+      -- TODO Do auto-focus (only if users did not focus since Building)+      when emptyErrors $ windowClose q s'+    (Notify msg) ->+      updateState+        ( \s ->+            if buildStatus s /= Building+              then s {buildStatus = Building, focus = Nothing, buildErrors = Vector.empty, buildWarnings = Vector.empty}+              else s+        )+        >> updateMsg msg+  trace h+  return mempty+  where+    display (Start _) = nvim_ h q $ echom $ show e+    display (Finish _ _) = nvim_ h q $ echom $ show e+    display (Notify (Message loc lvl _)) = nvim_ h q $ echo $ concat [show loc, " ", show lvl]+    trace Nothing = return ()+    trace _ = do+      s <- readTVarIO s'+      putLogLn h $ show s+    updateMsg msg = atomically $ modifyTVar' s' (f msg)+      where+        f x s = g x+          where+            g (Message loc Error txts) = s {buildErrors = Vector.snoc es (loc, txts)}+            g (Message loc Warning txts) = s {buildWarnings = Vector.snoc ws (loc, txts)}+            (es, ws) = case buildStatus s of+              Starting -> (Vector.empty, Vector.empty)+              _ -> (buildErrors s, buildWarnings s)+    updateState f = atomically $ modifyTVar' s' f++-- TODO Wrap this in an appropriate transformer+nvim :: Maybe Handle -> CommandQueue -> Command -> IO (Maybe Object)+nvim hLog q cmd = do+  r <- ask' q cmd+  case r of+    RPC.Success a -> return $ Just a+    RPC.Error err -> do+      putLogLn hLog $ show err+      return Nothing++nvim_ :: Maybe Handle -> CommandQueue -> Command -> IO ()+nvim_ h q c = nvim h q c >> return ()++-- TODO NEW STUFF, move above+-- TODO Important: could they all be into STM? how to avoid unnecessary readTVarIO?+-- There must be a useful `Async + STM` atomic layer++bufferSetLines :: CommandQueue -> TVar PluginState -> [Text] -> IO ()+bufferSetLines q s' txts = do+  s <- readTVarIO s'+  let b = buffer s+  (RPC.Success _) <- ask' q $ NvimBufSetLines b 0 64 False txts+  return ()++windowClose :: CommandQueue -> TVar PluginState -> IO ()+windowClose q s' = do+  s <- readTVarIO s'+  case window s of+    Nothing -> return ()+    Just w -> do+      -- Tolerate failure if window was closed manually by user+      _ <- ask' q $ NvimWinClose w False+      atomically . modifyTVar' s' $ \x -> x {window = Nothing}+      return ()++bufferShow :: CommandQueue -> TVar PluginState -> Int -> IO ()+bufferShow q s' height = do+  windowClose q s'+  (RPC.Success (ObjectInt rows)) <- ask' q (NvimWinGetHeight $ ObjectInt 0)+  (RPC.Success (ObjectInt cols)) <- ask' q (NvimWinGetWidth $ ObjectInt 0)+  s <- readTVarIO s'+  (RPC.Success w) <- ask' q $ openWin (buffer s) rows cols+  atomically . modifyTVar' s' $ \x -> x {window = Just w}+  return ()+  where+    openWin b rows cols =+      NvimOpenWin+        b+        False+        ( ObjectMap $+            ( Vector.fromList+                [ (ObjectStr $ Text.pack "style", ObjectStr $ Text.pack "minimal"),+                  (ObjectStr $ Text.pack "relative", ObjectStr $ Text.pack "win"),+                  (ObjectStr $ Text.pack "row", ObjectInt $ rows - height),+                  (ObjectStr $ Text.pack "col", ObjectInt 0),+                  (ObjectStr $ Text.pack "width", ObjectInt cols),+                  (ObjectStr $ Text.pack "height", ObjectInt height)+                ]+            )+        )++actionFocus :: Maybe Handle -> CommandQueue -> TVar PluginState -> Level -> Int -> IO ()+actionFocus hLog q s' lvl rank = do+  s <- readTVarIO s'+  let (loc, txts) = focusContent lvl rank s+  _ <- traverse (nvim_ hLog q) $ jumpTo loc+  bufferSetLines q s' txts+  bufferShow q s' $ length txts+  return ()++actionMove :: Maybe Handle -> CommandQueue -> TVar PluginState -> (PluginState -> PluginState) -> IO ()+actionMove hLog q s' f = do+  fcs <-+    atomically $ do+      s <- readTVar s'+      let s'' = f s+      writeTVar s' s''+      return $ focus s''+  case fcs of+    Nothing -> return ()+    Just (lvl, rank) -> actionFocus hLog q s' lvl rank++focusContent :: Level -> Int -> PluginState -> (Location, [Text])+focusContent lvl rank s = Vector.unsafeIndex xs rank+  where+    xs = case lvl of+      Warning -> buildWarnings s+      Error -> buildErrors s++focusDefault :: PluginState -> Maybe (Level, Int)+focusDefault s = select (Vector.null $ buildErrors s) (Vector.null $ buildWarnings s)+  where+    select False _ = Just (Error, 0)+    select True False = Just (Warning, 0)+    select True True = Nothing++focusMove :: Int -> PluginState -> PluginState+focusMove i s =+  case focus s of+    Nothing -> s {focus = focusDefault s}+    Just (lvl, rank) -> s {focus = Just $ f lvl (rank + i)}+  where+    f lvl rank | rank < 0 = f (toggle lvl) ((Vector.length $ select lvl) + rank)+    f lvl rank | rank >= (Vector.length $ select lvl) = f (toggle lvl) (rank - (Vector.length $ select lvl))+    f lvl rank = (lvl, rank)+    toggle lvl | Vector.null $ select (toggle' lvl) = lvl+    toggle lvl = toggle' lvl+    toggle' Warning = Error+    toggle' Error = Warning+    select Warning = buildWarnings s+    select Error = buildErrors s++-- TODO How to make it shudown gracefully? currently it's probably killed by nvim while blocking in `consumerOrWait` main :: IO () main = do-  hSetBuffering stdin NoBuffering-  hSetBuffering stdout NoBuffering-  b     <- getBroker-  t     <- getTopic b "."-  consumeOrWait t consumer-    where-      consumer Nothing  src = consumer (Just 0) src-      consumer (Just i) src = do-        i' <- runT $ final <~ sinkPart_ id (sinkIO publish <~ asParts) <~ converter i <~ src-        return (Left $ head i')-      converter :: Int -> ProcessT IO Event (Int, [Command])-      converter i = scan f (i, []) where f (first, _) event = convert first event-      publish cmd = do-        _ <- runCommand cmd-        return ()+  args <- getArgs+  case parseArgs args of+    Left err -> do+      putStrLn err+      exitWith $ ExitFailure 1+    Right logging -> do+      IO.hSetBuffering IO.stdin IO.NoBuffering+      IO.hSetBuffering IO.stdout IO.NoBuffering+      b <- getBroker+      t <- getTopic b "."+      hLog <- if logging then Just <$> (openLogFile t) else return Nothing+      qCmds <- atomically $ newTBQueue 8+      qNotifs <- atomically $ newTBQueue 8+      connClose <- mkConnection IO.stdin IO.stdout qCmds qNotifs (errHandler hLog)+      (Just buf) <- nvim hLog qCmds $ NvimCreateBuf False True+      state <- atomically $ newTVar $ pluginStateInit buf+      notifier <-+        async . runT_ $+          autoM (notify hLog qCmds state) <~ (auto parseAction) <~ (sourceIO . atomically $ readTBQueue qNotifs)+      _ <- traverse (nvim_ hLog qCmds) registerActions+      putLogLn hLog "ready"+      _ <- consumeOrWait t (consumer hLog state qCmds)+      cancel notifier+      connClose+      _ <- traverse IO.hClose hLog+      return ()+  where+    errHandler hLog err = do+      putLogLn hLog $ show err+    notify hLog q s' Focus = do+      s <- readTVarIO s'+      case focus s of+        Nothing ->+          case focusDefault s of+            Nothing -> nvim_ hLog q $ echom "nothing to fix"+            Just (lvl, rank) -> do+              atomically . modifyTVar' s' $ \x -> x {focus = Just (lvl, rank)}+              actionFocus hLog q s' lvl rank+        Just (lvl, rank) -> actionFocus hLog q s' lvl rank+    notify hLog q s' Next = actionMove hLog q s' (focusMove 1)+    notify hLog q s' Previous = actionMove hLog q s' (focusMove (-1))+    consumer h s q Nothing src = consumer h s q (Just 0) src+    consumer h s q (Just i) src = do+      i' <- runT $ final <~ asParts <~ fanout [quickFixes, pluginUpdate] <~ src+      return (Left $ head i')+      where+        quickFixes = auto (\x -> [x]) <~ sinkPart_ id (sinkIO (send q) <~ asParts) <~ toQuickFixes i+        pluginUpdate = autoM (update h q s)++    toQuickFixes :: Int -> ProcessT IO Event (Int, [Command])+    toQuickFixes acc = scan f (acc, [])+      where+        f (i, _) event = toQuickFix i event
sarsi-nvim/NVIM/Client.hs view
@@ -1,35 +1,81 @@ module NVIM.Client where --- | A primitive NVIM RPC synchronous client.--import Data.Binary.Machine (streamGet)+import Control.Concurrent.Async (Async, async, wait)+import Control.Concurrent.STM (STM, atomically)+import Control.Concurrent.STM.TBQueue (TBQueue, readTBQueue, writeTBQueue)+import Control.Concurrent.STM.TMVar (newEmptyTMVarIO, putTMVar, takeTMVar)+import Control.Concurrent.STM.TVar (modifyTVar', newTVar, stateTVar)+import Data.Binary.Machine (DecodingError (..), processPut, streamGet) import Data.Binary.Put (runPut) import Data.ByteString (hGetSome, hPut) import Data.ByteString.Lazy (toStrict)-import Data.Machine ((<~), asParts, auto, final, run, source)-import Data.MessagePack.Object (Object(..))-import Data.MessagePack.RPC (Answer(..), Request(..), Message(..), getMessage, putRequest)+import Data.Machine (autoM, final, run, runT_, source, (<~))+import qualified Data.Map as Map+import Data.MessagePack (Object (..))+import Data.MessagePack.RPC (Answer (..), Message (..), getMessage, putRequest) import Data.Text (Text)-import System.IO (Handle, stdin, stdout) import qualified Data.Text as Text+import NVIM.Command (Command (..), mkRequest)+import System.IO (Handle, stdin, stdout)+import System.IO.Machine (byChunk, sinkHandle, sourceHandle, sourceIO) -data Command = VimCommand [Object] | VimCallFunction Text [Object]+-- TODO Extract a generic asynchronous RPC client+-- need to write a proper scheduler first to support timeout on transaction+-- type JobQueue a = TBQueue (IO a, Maybe a -> STM (), UTCTime)+-- type CommandQueue = TBQueue (Command, Maybe Answer -> STM (), Duration) +-- Asynchronous client+type CommandQueue = TBQueue (Command, Answer -> STM ())++ask :: CommandQueue -> Command -> IO (Async Answer)+ask q cmd = do+  answer <- newEmptyTMVarIO+  atomically $ writeTBQueue q (cmd, putTMVar answer)+  async $ atomically $ takeTMVar answer++ask' :: CommandQueue -> Command -> IO Answer+ask' q c = wait =<< ask q c++send :: CommandQueue -> Command -> IO ()+send q c = atomically $ writeTBQueue q (c, \_ -> return ())++mkConnection :: Handle -> Handle -> CommandQueue -> TBQueue (Text, [Object]) -> (DecodingError -> IO ()) -> IO (IO ())+mkConnection hIn hOut qCommands qNotifs errHandler = do+  nonce <- atomically $ newTVar 0+  runnings <- atomically $ newTVar Map.empty+  sender <- async . runT_ $ outbound nonce qCommands runnings+  receiver <- async . runT_ $ inbound runnings+  return $ wait sender >> wait receiver+  where+    outbound nonce q rs =+      sinkHandle byChunk hOut <~ processPut putRequest+        <~ autoM (publish rs nonce)+        <~ (sourceIO . atomically $ readTBQueue q)+    inbound rs = autoM (dispatch rs) <~ streamGet getMessage <~ sourceHandle byChunk hIn+    dispatch rs (Right (Response msgId a)) = do+      cb <- atomically $ stateTVar rs (\rs' -> (Map.lookup msgId rs', Map.delete msgId rs'))+      case cb of+        Just cb' -> atomically $ cb' a+        Nothing -> return ()+    dispatch _ (Right ((Notification m ps))) = do+      atomically $ writeTBQueue qNotifs (m, ps)+    dispatch _ (Left err) = errHandler err+    publish rs nonce (cmd, callback) = do+      msgId <- atomically $ stateTVar nonce (\n -> (n, n + 1))+      atomically $ modifyTVar' rs (\rs' -> Map.insert msgId callback rs')+      return $ mkRequest msgId cmd++-- Helpers to run a command synchronously runCommand :: Command -> IO Answer runCommand = runCommandWith stdin stdout  runCommandWith :: Handle -> Handle -> Command -> IO Answer runCommandWith hIn hOut cmd = do-  hPut hOut $ toStrict $ runPut $ putRequest $ mkRequest cmd+  hPut hOut $ toStrict $ runPut $ putRequest $ mkRequest 0 cmd   xs <- hGetSome hIn 1024-  let ys = run $ final <~ asParts <~ auto unpack <~ streamGet getMessage <~ source [xs]+  let ys = run $ final <~ streamGet getMessage <~ source [xs]   return $ mkAnswer $ ys-    where-      mkAnswer [a] = a-      mkAnswer _   = Error $ ObjectStr $ Text.pack "No RPC answer received."-      mkRequest (VimCommand xs) =-        Request 0 (Text.pack "vim_command") xs-      mkRequest (VimCallFunction m xs) =-        Request 0 (Text.pack "vim_call_function") [ ObjectStr m, ObjectArray xs ]-      unpack (Right (Response _ a)) = [a]-      unpack _                      = []+  where+    mkAnswer [(Right (Response _ a))] = a+    mkAnswer [(Left (DecodingError _ err))] = Error . ObjectStr $ Text.pack err+    mkAnswer _ = Error $ ObjectStr $ Text.pack "No RPC answer received."
+ sarsi-nvim/NVIM/Command.hs view
@@ -0,0 +1,40 @@+module NVIM.Command where++import Data.MessagePack (Object (..))+import Data.MessagePack.RPC (Request (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector++-- TODO Support special types (with newtype over Object) for Buffer, Window, Tabpage (EXT 0, 1, 2)+-- see https://neovim.io/doc/user/api.html+data Command+  = NvimBufSetLines Object Int Int Bool [Text]+  | NvimCommand [Object]+  | NvimCallFunction Text [Object]+  | NvimCreateBuf Bool Bool -- {listed} {scratch}+  | NvimOpenWin Object Bool Object+  | NvimWinClose Object Bool+  | NvimWinGetBuf Object+  | NvimWinGetHeight Object+  | NvimWinGetWidth Object++mkRequest :: Int -> Command -> Request+mkRequest msgId (NvimBufSetLines b s e strict xs) =+  Request msgId (Text.pack "nvim_buf_set_lines") [b, ObjectInt s, ObjectInt e, ObjectBool strict, ObjectArray (Vector.fromList (ObjectStr <$> xs))]+mkRequest msgId (NvimCommand xs) =+  Request msgId (Text.pack "nvim_command") xs+mkRequest msgId (NvimCallFunction m xs) =+  Request msgId (Text.pack "nvim_call_function") [ObjectStr m, ObjectArray (Vector.fromList xs)]+mkRequest msgId (NvimCreateBuf l s) =+  Request msgId (Text.pack "nvim_create_buf") [ObjectBool l, ObjectBool s]+mkRequest msgId (NvimOpenWin b e cfg) =+  Request msgId (Text.pack "nvim_open_win") [b, ObjectBool e, cfg]+mkRequest msgId (NvimWinClose w force) =+  Request msgId (Text.pack "nvim_win_close") [w, ObjectBool force]+mkRequest msgId (NvimWinGetBuf w) =+  Request msgId (Text.pack "nvim_win_get_buf") [w]+mkRequest msgId (NvimWinGetHeight w) =+  Request msgId (Text.pack "nvim_win_get_height") [w]+mkRequest msgId (NvimWinGetWidth w) =+  Request msgId (Text.pack "nvim_win_get_width") [w]
+ sarsi-nvim/NVIM/QuickFix.hs view
@@ -0,0 +1,39 @@+module NVIM.QuickFix where++import Codec.Sarsi (Event (..), Level (..), Location (..), Message (..))+import Data.MessagePack (Object (..))+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import NVIM.Command (Command (NvimCallFunction))++toQuickFix :: Int -> Event -> (Int, [Command])+toQuickFix _ (Start _) = (0, [])+toQuickFix i (Finish _ _) = (0, (if i == 0 then [setqflistEmpty] else []))+toQuickFix i (Notify msg@(Message _ _ _)) = (i + 1, [setqflist (if i == 0 then "r" else "a") [mkQuickFix msg]])++-- TODO Sanitize text description by escaping special characters+mkQuickFix :: Message -> Object+mkQuickFix (Message (Location fp col ln) lvl txts) =+  ObjectMap $+    ( Vector.fromList+        [ (ObjectStr $ Text.pack "filename", ObjectStr fp),+          (ObjectStr $ Text.pack "lnum", ObjectInt ln),+          (ObjectStr $ Text.pack "col", ObjectInt col),+          (ObjectStr $ Text.pack "type", ObjectStr . Text.pack $ tpe lvl),+          (ObjectStr $ Text.pack "text", ObjectStr $ Text.unlines txts)+        ]+    )+  where+    tpe Error = "E"+    tpe Warning = "W"++setqflist :: String -> [Object] -> Command+setqflist action items =+  NvimCallFunction+    (Text.pack "setqflist")+    [ ObjectArray (Vector.fromList items),+      ObjectStr $ Text.pack action+    ]++setqflistEmpty :: Command+setqflistEmpty = setqflist "r" []
− sarsi-rs/Main.hs 
@@ -1,12 +0,0 @@-module Main where--import Codec.Sarsi.Rust (messageParser)-import Data.Attoparsec.Text.Machine (streamParser)-import Data.Machine ((<~), asParts, auto)-import Sarsi.Tools.Shell (mainShell)--main :: IO ()-main = mainShell "rust" (asParts <~ auto unpack <~ streamParser messageParser)-  where-    unpack (Right msg) = [msg]-    unpack (Left _)    = []
sarsi-sbt/Main.hs view
@@ -1,45 +1,45 @@ {-# LANGUAGE Rank2Types #-}+ module Main where  import Codec.Sarsi (Event) import Codec.Sarsi.SBT.Machine (eventProcess)-import Data.Machine (ProcessT, (<~), autoM, runT_)+import qualified Data.List as List+import Data.Machine (ProcessT, autoM, runT_, (<~))+import qualified Data.Text.IO as TextIO import Sarsi (getBroker, getTopic)+import qualified Sarsi as Sarsi import Sarsi.Producer (produce) import System.Environment (getArgs) import System.Exit (ExitCode, exitWith)-import System.Process (StdStream(..), shell, std_in, std_out)-import System.Process.Machine (ProcessMachines, callProcessMachines)-import System.IO (BufferMode(NoBuffering), hSetBuffering, stdin, stdout)+import System.IO (BufferMode (NoBuffering), hSetBuffering, stdin, stdout) import System.IO.Machine (byChunk)--import qualified Data.List as List-import qualified Data.Text.IO as TextIO-import qualified Sarsi as Sarsi+import System.Process (StdStream (..), shell, std_in, std_out)+import System.Process.Machine (ProcessMachines, callProcessMachines)  title :: String title = concat [Sarsi.title, "-sbt"]  -- TODO Contribute to machines-process mStdOut_ :: ProcessT IO a b -> ProcessMachines a a0 k0 -> IO ()-mStdOut_ mp (_, Just stdOut, _)  = runT_ $ mp <~ stdOut-mStdOut_ _  _                    = return ()+mStdOut_ mp (_, Just stdOut, _) = runT_ $ mp <~ stdOut+mStdOut_ _ _ = return ()  producer :: String -> ProcessT IO Event Event -> IO (ExitCode) producer cmd sink = do   (ec, _) <- callProcessMachines byChunk createProc (mStdOut_ pipeline)   return ec-    where-      pipeline = sink <~ eventProcess <~ echoText stdout-      echoText h = autoM $ (\txt -> TextIO.hPutStr h txt >> return txt)-      createProc  = (shell cmd) { std_in = Inherit, std_out = CreatePipe }+  where+    pipeline = sink <~ eventProcess <~ echoText stdout+    echoText h = autoM $ (\txt -> TextIO.hPutStr h txt >> return txt)+    createProc = (shell cmd) {std_in = Inherit, std_out = CreatePipe}  main :: IO () main = do   hSetBuffering stdin NoBuffering   hSetBuffering stdout NoBuffering-  args  <- getArgs-  b     <- getBroker-  t     <- getTopic b "."-  ec    <- produce t $ producer $ concat $ List.intersperse " " ("sbt":args)+  args <- getArgs+  b <- getBroker+  t <- getTopic b "."+  ec <- produce t $ producer $ concat $ List.intersperse " " ("sbt" : "-Dsbt.color=always" : args)   exitWith ec
sarsi-vi/Main.hs view
@@ -1,19 +1,18 @@ module Main where -import Data.Machine (ProcessT, (<~), asParts, final, scan, sinkPart_, runT)-import Codec.Sarsi (Event(..), Message(..), Level(..), Location(..))+import Codec.Sarsi (Event (..), Level (..), Location (..), Message (..)) import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar)+import qualified Data.List as List+import Data.Machine (ProcessT, asParts, final, runT, scan, sinkPart_, (<~)) import Data.Text (Text, pack)+import qualified Data.Text as Text import Data.Text.IO (hPutStrLn)-import Sarsi (Topic(..), getBroker, getTopic)+import Sarsi (Topic (..), getBroker, getTopic)+import qualified Sarsi as Sarsi import Sarsi.Consumer (consumeOrWait)-import System.IO (Handle, IOMode(WriteMode), hClose, hFlush, openFile)+import System.IO (Handle, IOMode (WriteMode), hClose, hFlush, openFile) import System.IO.Machine (sinkIO) -import qualified Data.List as List-import qualified Data.Text as Text-import qualified Sarsi as Sarsi- -- TODO Remove the MVar by impl. scanM ((a -> b -> m a) -> a -> ProcessT m (k b) a) in machines  title :: String@@ -23,47 +22,49 @@ toVi :: Message -> Text toVi (Message (Location fp col ln) lvl txts) = Text.concat [header, pack " ", body]   where-    header  = Text.concat $ List.intersperse (pack ":") [fp, pack $ show  ln, pack $ show  col, tpe lvl]-    body    = Text.concat $ List.intersperse (pack " ") txts+    header = Text.concat $ List.intersperse (pack ":") [fp, pack $ show ln, pack $ show col, tpe lvl]+    body = Text.concat $ List.intersperse (pack " ") txts     tpe Error = pack "e"     tpe Warning = pack "w" -data Action = Append | Replace deriving Show-data LogEvent = LogEvent Action Text deriving Show+data Action = Append | Replace deriving (Show) -data Command = Throw LogEvent | Echo String+data LogEvent = LogEvent Action Text deriving (Show) +data Command = Throw LogEvent | Echo String deriving (Show)+ convert :: Bool -> Event -> (Bool, [Command])-convert first (Notify msg@(Message loc lvl _))  = (False, [Throw e, Echo $ concat [show loc, " ", show lvl]])+convert first (Notify msg@(Message loc lvl _)) = (False, [Throw e, Echo $ concat [show loc, " ", show lvl]])   where     e = LogEvent mode $ toVi msg     mode = if first then Replace else Append-convert _     e             = (True, [Echo $show e])+convert _ e = (True, [Echo $show e])  converter :: Bool -> ProcessT IO Event (Bool, [Command]) converter first = scan f (first, []) where f (first', _) event = convert first' event  dump :: FilePath -> Maybe Handle -> Command -> IO (Maybe Handle)-dump _  h         (Echo txt)                      = (putStrLn $ concat [title, ": ", txt]) >> return h-dump fp Nothing   e                               = openFile fp WriteMode >>= \h -> dump fp (Just h) e-dump _  (Just h)  (Throw (LogEvent Append txt))   = fmap (const $ Just h) $ (hPutStrLn h txt >> hFlush h)-dump fp (Just h)  (Throw (LogEvent Replace txt))  = hClose h >> dump fp Nothing (Throw $ LogEvent Append txt)+dump _ h (Echo txt) = (putStrLn $ concat [title, ": ", txt]) >> return h+dump fp Nothing e = openFile fp WriteMode >>= \h -> dump fp (Just h) e+dump _ (Just h) (Throw (LogEvent Append txt)) = fmap (const $ Just h) $ (hPutStrLn h txt >> hFlush h)+dump fp (Just h) (Throw (LogEvent Replace txt)) = hClose h >> dump fp Nothing (Throw $ LogEvent Append txt)  writer :: FilePath -> MVar (Maybe Handle) -> Command -> IO () writer tp var c = do-  h   <- readMVar var-  h'  <- dump fp h c-  _   <- swapMVar var h'+  h <- readMVar var+  h' <- dump fp h c+  _ <- swapMVar var h'   return ()-    where fp = tp ++ ".vi"+  where+    fp = tp ++ ".vi"  main :: IO () main = do-  b     <- getBroker-  t     <- getTopic b "."-  var   <- newMVar Nothing+  b <- getBroker+  t <- getTopic b "."+  var <- newMVar Nothing   consumeOrWait t $ consumer t var-    where-      consumer (Topic _ tp) var first src = do-        res <- runT $ final <~ sinkPart_ id ((sinkIO $ writer tp var) <~ asParts)  <~ converter (maybe True id first) <~ src-        return $ Left $ head res+  where+    consumer (Topic _ tp) var first src = do+      res <- runT $ final <~ sinkPart_ id ((sinkIO $ writer tp var) <~ asParts) <~ converter (maybe True id first) <~ src+      return $ Left $ head res
sarsi.cabal view
@@ -1,10 +1,8 @@ name:                sarsi-version:             0.0.4.0+version:             0.0.5.1 synopsis:            A universal quickfix toolkit and his protocol.-  description:   Usage overview can be found in the <http://github.com/aloiscochard/sarsi#sarsi README>.- homepage:            http://github.com/aloiscochard/sarsi license:             Apache-2.0 license-file:        LICENSE@@ -20,64 +18,60 @@   ghc-options:          -Wall   exposed-modules:     Codec.Sarsi+    Codec.Sarsi.Curses     Codec.Sarsi.GHC+    -- TODO Extract in rosetta     Codec.Sarsi.Rust     Codec.Sarsi.SBT     Codec.Sarsi.SBT.Machine+    Rosetta     Sarsi     Sarsi.Consumer+    Sarsi.Processor     Sarsi.Producer-    Sarsi.Tools.Shell+    Sarsi.Tools.Pipe     Sarsi.Tools.Trace-    -- TODO Extract in a `codec-ghc-log` module+    -- TODO Extract in a `codec-ghc-log` module or in rosetta     Codec.GHC.Log     -- TODO Extract in a `machines-attoparsec` module     Data.Attoparsec.Machine     Data.Attoparsec.Text.Machine   build-depends:       base                  >= 4.6.0.1    && < 5-    , async                 >= 2.1        && < 2.2+    , ansi-terminal         >= 0.10       && < 0.12+    , async                 >= 2.1        && < 2.3     , attoparsec            >= 0.12       && < 0.14     , binary                >= 0.7        && < 0.9     , bytestring            >= 0.10       && < 0.11-    , containers            >= 0.5        && < 0.6-    , cryptonite            >= 0.10       && < 0.21-    , data-msgpack          >= 0.0.3      && < 0.1-    , directory             >= 1.2        && < 1.3+    , containers            >= 0.5        && < 0.7+    , cryptonite            >= 0.10       && < 0.29+    , msgpack               >= 1.0        && < 1.1+    , directory             >= 1.2        && < 1.4     , filepath              >= 1.4        && < 1.5-    , fsnotify              >= 0.2        && < 0.3-    , machines              >= 0.6        && < 0.7-    , machines-binary       >= 0.3.0.2    && < 0.4-    , machines-process      >= 0.2.0.6    && < 0.3-    , machines-io           >= 0.2.0.12   && < 0.3-    , network               >= 2.6        && < 2.7-    , process               >= 1.1        && < 1.5-    , stm                   >= 2.4        && < 2.5+    , fsnotify              >= 0.2        && < 0.4+    , machines              >= 0.7        && < 0.8+    , machines-binary       >= 7.0        && < 7.1+    , machines-process      >= 7.0.0.2    && < 7.1+    , machines-io           >= 7.0        && < 7.1+    , network               >= 3.1        && < 3.2+    , process               >= 1.1        && < 1.7+    , stm                   >= 2.4        && < 2.6     , text                  >= 1.2        && < 1.3-    , vector                >= 0.10       && < 0.12+    , vector                >= 0.10       && < 0.13  executable sarsi    main-is:              Main.hs   other-modules:     Paths_sarsi-  build-depends:       +  build-depends:       base+    , sarsi     , Cabal-    , sarsi                 == 0.0.4.0+    , containers   hs-source-dirs:       sarsi   ghc-options:          -Wall -threaded   default-language:     Haskell2010 -executable sarsi-hs-  main-is:              Main.hs-  build-depends:       -      base-    , sarsi                 == 0.0.4.0-    , machines-  hs-source-dirs:       sarsi-hs-  ghc-options:          -Wall -dynamic -threaded-  default-language:     Haskell2010- executable sarsi-nvim   main-is:              Main.hs   other-modules:@@ -86,10 +80,12 @@     Data.MessagePack.RPC     -- TODO Extract in a lightweight nvim client.     NVIM.Client-    -- NVIM.Info-  build-depends:       +    NVIM.Command+    NVIM.QuickFix+  build-depends:       base-    , sarsi                 == 0.0.4.0+    , sarsi+    , async     , machines     , binary     , bytestring@@ -97,32 +93,23 @@     , machines     , machines-binary     , machines-io-    , data-msgpack+    , msgpack     , network     , process     , text+    , stm     , vector     , unordered-containers  >= 0.2        && < 0.3   hs-source-dirs:       sarsi-nvim   ghc-options:          -Wall -dynamic -threaded   default-language:     Haskell2010 -executable sarsi-rs-  main-is:              Main.hs-  build-depends:       -      base-    , sarsi                 == 0.0.4.0-    , machines-  hs-source-dirs:       sarsi-rs-  ghc-options:          -Wall -dynamic -threaded-  default-language:     Haskell2010- executable sarsi-sbt   main-is:              Main.hs   other-modules:-  build-depends:       +  build-depends:       base-    , sarsi                 == 0.0.4.0+    , sarsi     , machines     , machines-io     , machines-process@@ -134,9 +121,9 @@  executable sarsi-vi   main-is:              Main.hs-  build-depends:       +  build-depends:       base-    , sarsi                 == 0.0.4.0+    , sarsi     , directory     , filepath     , machines@@ -144,5 +131,20 @@     , text     , vector   hs-source-dirs:       sarsi-vi+  ghc-options:          -Wall -dynamic -threaded+  default-language:     Haskell2010++executable srs+  main-is:              srs.hs+  build-depends:+      base+    , sarsi+    , async+    , bytestring+    , machines+    , machines-io+    , machines-process+    , process+  hs-source-dirs:       exe   ghc-options:          -Wall -dynamic -threaded   default-language:     Haskell2010
sarsi/Main.hs view
@@ -1,20 +1,42 @@ module Main where -import Distribution.Text+import qualified Data.List as List+import qualified Data.Set as Set+import Data.Version (showVersion)+import Paths_sarsi (version)+import qualified Rosetta as Rosetta import Sarsi (getBroker, getSockAddr, getTopic, title)-import Sarsi.Tools.Trace (traceHS, traceRS, traceSBT)-import System.IO (stdin)+import Sarsi.Processor (languageProcess, processAll, processAny)+import Sarsi.Tools.Pipe (pipe)+import Sarsi.Tools.Trace (traceCleanCurses, traceHS, traceRS, traceSBT, traceSBTCurses) import System.Environment (getArgs)--import Paths_sarsi (version)+import System.IO (stdin)  main :: IO ()-main = getArgs >>= run where-  run ["--trace-hs"]  = traceHS stdin-  run ["--trace-rs"]  = traceRS stdin-  run ["--trace-sbt"] = traceSBT stdin-  run ["--version"]   = putStrLn $ concat [title, "-", display version]-  run _ = do-    b     <- getBroker-    t     <- getTopic b "."-    print $ getSockAddr t+main = getArgs >>= run+  where+    run ["--trace", "clean-curses"] = traceCleanCurses stdin+    run ["--trace", "hs"] = traceHS stdin+    run ["--trace", "rs"] = traceRS stdin+    run ["--trace", "sbt"] = traceSBT stdin+    run ["--trace", "sbt-curses"] = traceSBTCurses stdin+    run ["--topic"] = do+      b <- getBroker+      t <- getTopic b "."+      print $ getSockAddr t+    run ["--version"] = putStrLn $ concat [title, "-", showVersion version]+    run [] = pipe "any" processAny+    run exts = case Set.fromList <$> traverse parseExt exts of+      Right languageTags -> do+        ps <- traverse fetchProcess $ Set.toList languageTags+        pipe (concat $ List.intersperse "+" (Rosetta.languageLabel <$> (Set.toList languageTags))) (processAll $ ps >>= id)+      Left err -> putStrLn $ concat [title, ": ", err]+    fetchProcess lt = case languageProcess lt of+      Just process -> return [process]+      Nothing -> do+        putStrLn $ concat [title, ": ", "unsupported language '", Rosetta.languageLabel lt, "'"]+        return []+    parseExt ext =+      case Rosetta.fromExtension ext of+        Just lt -> Right lt+        Nothing -> Left (concat ["invalid extension '", ext, "'."])
src/Codec/Sarsi.hs view
@@ -1,17 +1,16 @@ module Codec.Sarsi where -import Data.Int (Int64)-import Data.Text (Text, unpack) import Data.Binary (Get, Put)- import qualified Data.MessagePack.Get as Get import qualified Data.MessagePack.Put as Put+import Data.Text (Text, unpack) import qualified Data.Text as Text+import qualified Data.Vector as Vector  data Event-  = Start { label :: Text }-  | Finish { errors :: Int64, warnings :: Int64 }-  | Notify { message :: Message }+  = Start {label :: Text}+  | Finish {errors :: Int, warnings :: Int}+  | Notify {message :: Message}  instance Show Event where   show (Start lbl) = concat ["starting ", unpack lbl, " build"]@@ -37,17 +36,21 @@  data Message = Message Location Level [Text] +-- TODO Remove me+messageTest :: Message+messageTest = Message (Location {filePath = Text.pack "foo", column = 42, line = 42}) Error []+ instance Show Message where   show (Message loc lvl txts) =     (concat [show loc, " ", show lvl, "\n"]) ++ (unlines $ Text.unpack <$> txts)  getMessage :: Get Message-getMessage = Message <$> getLocation <*> getLevel <*> Get.getArray Get.getStr+getMessage = Message <$> getLocation <*> getLevel <*> (Vector.toList <$> Get.getArray Get.getStr)  putMessage :: Message -> Put-putMessage (Message loc lvl txt) = putLocation loc *> putLevel lvl *> Put.putArray Put.putStr txt+putMessage (Message loc lvl txt) = putLocation loc *> putLevel lvl *> Put.putArray Put.putStr (Vector.fromList txt) -data Location = Location { filePath :: Text, column :: Int64, line :: Int64 }+data Location = Location {filePath :: Text, column :: Int, line :: Int}  instance Show Location where   show (Location fp c l) = concat [Text.unpack fp, "@", show l, ":", show c]@@ -66,4 +69,3 @@  putLevel :: Level -> Put putLevel = Put.putInt . fromIntegral . fromEnum-
+ src/Codec/Sarsi/Curses.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}++module Codec.Sarsi.Curses where++import Data.Attoparsec.Text+import qualified Data.Attoparsec.Text as AttoText+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text++-- note: expect a line that does NOT ends with a LF+cleanLine :: Text -> Text+cleanLine txt | Text.null txt = txt+cleanLine txt | Text.last txt == '\r' = fromMaybe Text.empty $ (f . fst) <$> Text.unsnoc txt+  where+    f x = case Text.breakOnAll "\r" x of+      [] -> x+      xs -> Text.tail $ (snd . last) xs+cleanLine txt = txt++-- Note: this parser remove CSI codes and do a best effort+-- at removing "clear line" instructions while keeping+-- all information exposed without any mangling.+cleaningCurses :: Parser Text+cleaningCurses = choice [multiples, single, none]+  where+    multiples = do+      before <- ln+      middle <- choice [silenceClearLines, silenceCSI]+      after <- choice [multiples, single]+      return $ Text.concat [before, "\n", middle, after]+      where+        ln = do+          before <- AttoText.takeWhile (breakAt . fromEnum)+          after <- choice [lineFinish, lineContinue]+          return (Text.concat [before, after])+          where+            breakAt 10 = False -- LF+            breakAt 27 = False -- ESC+            breakAt _ = True+        lineFinish = char '\n' >> (return $ Text.pack "\n")+        lineContinue = csi >> ln+        silenceClearLines = do+          _ <- AttoText.takeWhile (not . isEsc . fromEnum)+          _ <- choice [AttoText.many1 (cl <* "\n"), AttoText.many1 cl]+          return Text.empty+    single = do+      befores <- many1 $ choice [clearLine, silenceCSI]+      str <- AttoText.many1 anyChar+      _ <- endOfInput+      return (Text.concat [Text.concat befores, Text.pack str])+      where+        clearLine = do+          _ <- AttoText.takeWhile (not . isEsc . fromEnum)+          _ <- AttoText.many1 cl+          return Text.empty+    none = do+      ln <- (AttoText.takeWhile $ \w -> w /= '\n')+      _ <- "\n"+      return $ Text.concat [ln, "\n"]+    cl = csiHeader >> string "2K" >> return ()+    silenceCSI = do+      txt <- AttoText.takeWhile (not . isEsc . fromEnum)+      _ <- AttoText.many1 csi+      return txt++-- CSI (Control Sequence Introducer) sequences+csi :: Parser Text+csi = do+  _ <- csiHeader+  param <- takeWhileInRange 0x30 0x3F+  inter <- takeWhileInRange 0x20 0x2F+  final <- satisfy ((inRange 0x40 0x7E) . fromEnum)+  return $ Text.concat [param, inter, Text.singleton final]+  where+    takeWhileInRange l u = AttoText.takeWhile (inRange l u . fromEnum)+    inRange l u i | i >= l && i <= u = True+    inRange _ _ _ = False++csiHeader :: Parser ()+csiHeader = (satisfy (isEsc . fromEnum) <* char '[') >> return ()++isEsc :: Int -> Bool+isEsc 27 = True+isEsc _ = False
src/Codec/Sarsi/Rust.hs view
@@ -1,37 +1,27 @@ {-# LANGUAGE OverloadedStrings #-}-module Codec.Sarsi.Rust where -import Codec.Sarsi (Level(..), Location(..), Message(..))+module Codec.Sarsi.Rust where +import Codec.Sarsi (Level (..), Location (..), Message (..)) import Data.Attoparsec.Text  messageParser :: Parser Message-messageParser = choice [formatA, formatB] where-    formatA    = do-      fp  <- takeWhile1 (\c -> c /= sepChar && c /= '\n' && c /= '\r') <* char sepChar-      n   <- decimal <* char sepChar-      c   <- decimal <* char sepChar-      _   <- untilSep <* char sepChar-      _   <- untilSpace *> space-      l   <- choice-        [ string "warning: " *> return Warning-        , string "error: " *> return Error ]-      txt <- untilLineBreak <* ("\n" <* end)-      return $ Message (Location fp c n) l [txt]--    formatB    = do-      l   <- choice-        [ string "warning"  *> untilSep0 *> string ": " *> return Warning-        , string "error"    *> untilSep0 *> string ": " *> return Error   ]-      txt <- untilLineBreak <* "\n"-      fp  <- many1 space *> "--> " *> untilSep <* char sepChar-      n   <- decimal <* char sepChar-      c   <- decimal <* end-      return $ Message (Location fp c n) l [txt]--    untilSep   = takeWhile1 $ \w -> w /= sepChar-    untilSep0  = Data.Attoparsec.Text.takeWhile $ \w -> w /= ':'-    untilSpace = takeWhile1 $ \w -> w /= ' '+messageParser = do+  l <-+    choice+      [ string "warning" *> untilSep0 *> string ": " *> return Warning,+        string "error" *> untilSep0 *> string ": " *> return Error+      ]+  body <- untilLineBreak <* "\n"+  fp <- many1 space *> "--> " *> untilSep <* char sepChar+  n <- decimal <* char sepChar+  c <- decimal <* "\n"+  comments <- many' (untilLineBreak <* "\n")+  _ <- end+  return $ Message (Location fp c n) l (body : comments)+  where+    untilSep = takeWhile1 $ \w -> w /= sepChar+    untilSep0 = Data.Attoparsec.Text.takeWhile $ \w -> w /= ':'     end = choice [const () <$> "\n", endOfInput, return ()]     sepChar = ':'-    untilLineBreak = takeWhile1 $ \w -> w /= '\n' && w /= '\r'+    untilLineBreak = takeWhile1 $ \w -> w /= '\n'
src/Codec/Sarsi/SBT.hs view
@@ -1,67 +1,63 @@ {-# LANGUAGE OverloadedStrings #-}+ module Codec.Sarsi.SBT where -import Codec.Sarsi (Level(..), Location(..), Message(..))+import Codec.Sarsi (Level (..), Location (..), Message (..)) import Data.Attoparsec.Combinator (lookAhead) import Data.Attoparsec.Text-import Data.Text (Text)- import qualified Data.Attoparsec.Text as AttoText+import Data.Text (Text) import qualified Data.Text as Text  data SBTEvent = CompileStart Text | TaskFinish Bool Text | Throw Message-  deriving Show+  deriving (Show) +cleaningCursesSBT :: Parser Text+cleaningCursesSBT = choice [silent, empty, keep]+  where+    silent = "  | =>" >> untilLineBreak >> "\n" >> return Text.empty+    empty = do+      _ <- AttoText.takeWhile1 $ \w -> w == '\n'+      return Text.empty+    keep = do+      content <- (AttoText.takeWhile1 $ \w -> w /= '\n') <* end+      return $ content `Text.snoc` '\n'+ eventParser :: Parser SBTEvent eventParser = choice [compile, finish, Throw <$> messageParser]   where     compile = do-      txt <- string "[info] Compiling " *> untilLineBreak <* end+      txt <- string "[info] " *> choice ["Build triggered", "Compiling"] *> untilLineBreak <* end       return $ CompileStart txt     finish = do       res <- status <* space       txt <- string "Total time: " *> untilLineBreak <* end-      _   <- end+      _ <- end       return $ TaskFinish res txt-        where-          status = choice [string "[success]" *> return True, string "[error]" *> return False]+      where+        status = choice [string "[success]" *> return True, string "[error]" *> return False]  messageParser :: Parser Message messageParser = do   lvl <- lineStart-  fp  <- takeWhile1 (\c -> c /= sepChar && c /= '\n' && c /= '\r') <* char sepChar-  ln  <- decimal <* char sepChar-  t   <- space *> (untilLineBreak <* "\n")-  ts  <- manyTill' (lineStart *> (untilLineBreak <* "\n")) (lookAhead $ column')-  col <- column'-  _   <- end-  return $ Message (Location fp (fromIntegral col) ln) lvl $ formatTxts t ts-    where-      level = choice [string "[error]" *> return Error, string "[warn]" *> return Warning]-      lineStart = level <* space-      sepChar = ':'-      formatTxts t [] = [t]-      formatTxts t ts = t : init ts-      column' = level *> ((length <$> many1 space) <* "^\n")--cleanEC :: Parser Text-cleanEC = choice [noEC, withEC]+  fp <- takeWhile1 (\c -> c /= sepChar && c /= '\n') <* char sepChar+  ln <- decimal <* char sepChar+  col <- decimal <* char sepChar+  t <- space *> (untilLineBreak <* "\n")+  ts <- manyTill' (lineStart *> (untilLineBreak <* "\n")) (lookAhead $ column')+  _ <- column' -- ignored as it was parsed above+  _ <- end+  return $ Message (Location fp col ln) lvl $ formatTxts t ts   where-    noEC    = takeStart <* endOfInput-    withEC  = do-      before <- takeStart <* anyChar-      _      <- takeEnd   <* anyChar-      after  <- cleanEC-      return (Text.concat [before, after])-    takeStart = AttoText.takeWhile (not . isEscStart . fromEnum)-    takeEnd   = AttoText.takeWhile (not . isEscEnd . fromEnum)-    isEscStart 27 = True-    isEscStart _  = False-    isEscEnd 109 = True-    isEscEnd _ = False+    level = choice [string "[error]" *> return Error, string "[warn]" *> return Warning]+    lineStart = level <* space+    sepChar = ':'+    formatTxts t [] = [t]+    formatTxts t ts = t : init ts+    column' = level *> ((length <$> many1 space) <* "^\n")  untilLineBreak :: Parser Text-untilLineBreak = takeWhile1 $ \w -> w /= '\n' && w /= '\r'+untilLineBreak = takeWhile1 $ \w -> w /= '\n'  end :: Parser () end = choice [const () <$> "\n", endOfInput, return ()]
src/Codec/Sarsi/SBT/Machine.hs view
@@ -1,12 +1,11 @@ module Codec.Sarsi.SBT.Machine where -import Codec.Sarsi (Event(..), Message(..), Level(..))-import Codec.Sarsi.SBT (SBTEvent(..), eventParser, cleanEC, untilLineBreak, end)-import Data.Attoparsec.Text.Machine (processParser, streamParser)-import Data.Int (Int64)-import Data.Machine (ProcessT, (<~), asParts, auto, scan)+import Codec.Sarsi (Event (..), Level (..), Message (..))+import Codec.Sarsi.Curses (cleaningCurses)+import Codec.Sarsi.SBT (SBTEvent (..), cleaningCursesSBT, eventParser)+import Data.Attoparsec.Text.Machine (asLines, processParser, streamParser)+import Data.Machine (ProcessT, asParts, auto, filtered, scan, (<~)) import Data.Text (Text)- import qualified Data.Text as Text  eventProcess :: Monad m => ProcessT m Text Event@@ -14,34 +13,33 @@   where     f (session, _) event = runSession session event     unpack (_, Just e) = [e]-    unpack _           = []+    unpack _ = []  eventProcess' :: Monad m => ProcessT m Text SBTEvent eventProcess' = asParts <~ auto unpackEvent <~ streamParser eventParser <~ preprocessing   where-    preprocessing =-      asParts <~ auto unpackEC <~ processParser cleanEC <~ asParts <~ auto unpackLine <~ streamParser byLine-        where byLine = untilLineBreak <* end-    unpackEvent (Right e)  = [e]-    unpackEvent (Left _)  = []-    unpackEC (Left _)     = []-    unpackEC (Right (_, txt))  = [txt]-    unpackLine (Right txt)  = [txt `Text.snoc` '\n']-    unpackLine (Left _)     = []-+    preprocessing = filtered (not . Text.null) <~ parsing cleaningCursesSBT <~ parsing cleaningCurses <~ input+      where+        input = auto (\txt -> Text.snoc txt '\n') <~ asLines+        parsing p = asParts <~ auto f <~ processParser p+          where+            f (Left _) = []+            f (Right (_, txt)) = [txt]+    unpackEvent (Right e) = [e]+    unpackEvent (Left _) = [] -data Session = Session { isBuilding :: Bool, counts :: (Int64, Int64) }-  deriving Show+data Session = Session {isBuilding :: Bool, counts :: (Int, Int)}+  deriving (Show)  emptySession :: Session emptySession = Session False (0, 0)  runSession :: Session -> SBTEvent -> (Session, Maybe Event)-runSession (Session False f)     (CompileStart _)  = (Session True   f,            Just $ Start $ Text.pack "scala")-runSession (Session False f)     _                 = (Session False  f,            Nothing)-runSession (Session True f)      (CompileStart _)  = (Session True   f,            Nothing)-runSession (Session True (e,w))  (TaskFinish _ _)  = (Session False  (0, 0),       Just $ Finish e w)-runSession (Session True f)      (Throw msg)       = (Session True   (inc msg f),  Just $ Notify msg)+runSession (Session False f) (CompileStart _) = (Session True f, Just $ Start $ Text.pack "scala")+runSession (Session False f) _ = (Session False f, Nothing)+runSession (Session True f) (CompileStart _) = (Session True f, Nothing)+runSession (Session True (e, w)) (TaskFinish _ _) = (Session False (0, 0), Just $ Finish e w)+runSession (Session True f) (Throw msg) = (Session True (inc msg f), Just $ Notify msg)   where     inc (Message _ Warning _) (e, w) = (e, w + 1)-    inc (Message _ Error _)   (e, w) = (e + 1, w)+    inc (Message _ Error _) (e, w) = (e + 1, w)
src/Data/Attoparsec/Machine.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE Rank2Types #-}+ module Data.Attoparsec.Machine where -import Data.Attoparsec.Internal.Types (IResult(..))-import Data.Machine (MachineT(..), ProcessT, Step(Await, Yield), Is(Refl), stopped)+import Data.Attoparsec.Internal.Types (IResult (..))+import Data.Machine (Is (Refl), MachineT (..), ProcessT, Step (Await, Yield), stopped)  streamParserWith :: (Monoid i, Monad m) => (i -> IResult i a) -> ProcessT m i (Either String a)-streamParserWith runParser = start where-  start = MachineT . return $ Await parse Refl stopped-  parse i = MachineT . return . f $ runParser i-  f (Fail _ _ e)  = Yield (Left e) start-  f (Partial c)   = Await (MachineT . return . f . c) Refl $ (MachineT . return . f $ c mempty)-  f (Done i r)    = Yield (Right r) (parse i)+streamParserWith runParser = start+  where+    start = MachineT . return $ Await parse Refl stopped+    parse i = MachineT . return . f $ runParser i+    f (Fail _ _ e) = Yield (Left e) start+    f (Partial c) = Await (MachineT . return . f . c) Refl $ (MachineT . return . f $ c mempty)+    f (Done i r) = Yield (Right r) (parse i)  processParserWith :: (Monoid i, Monad m) => (i -> IResult i a) -> ProcessT m i (Either String (i, a))-processParserWith runParser = MachineT . return $ Await parse Refl stopped where-  parse i = MachineT . return . f $ runParser i-  f (Fail _ _ e)  = Yield (Left e) (processParserWith runParser)-  f (Partial c)   = f $ c mempty-  f (Done i a)    = Yield (Right (i, a)) (processParserWith runParser)+processParserWith runParser = MachineT . return $ Await parse Refl stopped+  where+    parse i = MachineT . return . f $ runParser i+    f (Fail _ _ e) = Yield (Left e) (processParserWith runParser)+    f (Partial c) = f $ c mempty+    f (Done i a) = Yield (Right (i, a)) (processParserWith runParser)
src/Data/Attoparsec/Text/Machine.hs view
@@ -1,13 +1,20 @@-module Data.Attoparsec.Text.Machine where+{-# LANGUAGE OverloadedStrings #-} -import Data.Attoparsec.Text (Parser, parse)-import Data.Text (Text)-import Data.Machine (ProcessT)+module Data.Attoparsec.Text.Machine where  import Data.Attoparsec.Machine (processParserWith, streamParserWith)+import Data.Attoparsec.Text (Parser, parse, takeWhile)+import Data.Machine (ProcessT, asParts, auto, (<~))+import Data.Text (Text) -streamParser :: Monad m => Parser a -> ProcessT m Text (Either String a)-streamParser p = streamParserWith $ parse p+asLines :: Monad m => ProcessT m Text Text+asLines = asParts <~ auto unpackLine <~ streamParser ((Data.Attoparsec.Text.takeWhile $ \w -> w /= '\n') <* "\n")+  where+    unpackLine (Right txt) = [txt]+    unpackLine (Left _) = []  processParser :: Monad m => Parser a -> ProcessT m Text (Either String (Text, a)) processParser p = processParserWith $ parse p++streamParser :: Monad m => Parser a -> ProcessT m Text (Either String a)+streamParser p = streamParserWith $ parse p
+ src/Rosetta.hs view
@@ -0,0 +1,60 @@+module Rosetta where++import Data.List (find)++fromExtension :: String -> Maybe LanguageTag+fromExtension ext = find (\t -> languageExtension t == ext) languageTags++fromTool :: String -> Maybe ProjectTag+fromTool tool = find (\t -> projectTool t == tool) projectTags++data LanguageTag = CS | FS | HS | JV | NX | RS | SC+  deriving (Bounded, Enum, Eq, Ord)++languageExtension :: LanguageTag -> String+languageExtension CS = "cs"+languageExtension FS = "fs"+languageExtension HS = "hs"+languageExtension JV = "java"+languageExtension NX = "nix"+languageExtension RS = "rs"+languageExtension SC = "scala"++languageTags :: [LanguageTag]+languageTags = [minBound ..]++languageLabel :: LanguageTag -> String+languageLabel CS = "csharp"+languageLabel FS = "fsharp"+languageLabel HS = "haskell"+languageLabel JV = "java"+languageLabel NX = "nix"+languageLabel RS = "rust"+languageLabel SC = "scala"++data ProjectTag = CABAL | CARGO | DOTNET | NIX | SBT | STACK+  deriving (Bounded, Enum, Eq, Ord)++projectTags :: [ProjectTag]+projectTags = [minBound ..]++projectLanguages :: ProjectTag -> [LanguageTag]+projectLanguages CABAL = [HS]+projectLanguages CARGO = [RS]+projectLanguages DOTNET = [CS, FS]+projectLanguages NIX = [NX]+projectLanguages SBT = [JV, SC]+projectLanguages STACK = [HS]++projectTool :: ProjectTag -> String+projectTool CABAL = "cabal"+projectTool CARGO = "cargo"+projectTool DOTNET = "dotnet"+projectTool NIX = "nix-shell"+projectTool SBT = "sbt"+projectTool STACK = "stack"++projectToolBuildArgs :: ProjectTag -> [String]+projectToolBuildArgs NIX = ["."]+projectToolBuildArgs SBT = ["compile"]+projectToolBuildArgs _ = ["build"]
src/Sarsi.hs view
@@ -2,11 +2,10 @@  import Crypto.Hash (Digest, hash) import Crypto.Hash.Algorithms (MD5)-import Network.Socket (Family(AF_UNIX), SockAddr(SockAddrUnix), Socket, SocketType(Stream), defaultProtocol, socket)-import System.Directory (getTemporaryDirectory, createDirectory, doesDirectoryExist, doesFileExist, makeAbsolute, removeFile)-import System.FilePath ((</>))- import qualified Data.ByteString.Char8 as BSC8+import Network.Socket (Family (AF_UNIX), SockAddr (SockAddrUnix), Socket, SocketType (Stream), defaultProtocol, socket)+import System.Directory (XdgDirectory (XdgCache), createDirectory, doesDirectoryExist, doesFileExist, getXdgDirectory, makeAbsolute, removeFile)+import System.FilePath ((</>))  title :: String title = "sarsi"@@ -17,15 +16,14 @@  getBroker :: IO Broker getBroker = do-  tmp <- getTemporaryDirectory-  let bp = tmp </> title+  bp <- getXdgDirectory XdgCache title   let broker = Broker bp   exists <- doesDirectoryExist bp   if exists then return broker else createDirectory bp >> return broker  getTopic :: Broker -> FilePath -> IO Topic getTopic b@(Broker bp) fp' = do-  fp    <- makeAbsolute fp'+  fp <- makeAbsolute fp'   return $ Topic b $ bp </> (show $ (hash $ BSC8.pack fp :: Digest MD5))  removeTopic :: Topic -> IO ()
src/Sarsi/Consumer.hs view
@@ -1,29 +1,30 @@ {-# LANGUAGE Rank2Types #-}+ module Sarsi.Consumer where  import Codec.Sarsi (Event, getEvent)-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Exception (IOException, bracket, try)-import Data.Binary.Machine (processGet)-import Data.Machine ((<~), auto, asParts)+import Data.Binary.Machine (streamGet)+import Data.Machine (asParts, auto, (<~)) import Network.Socket (connect, socketToHandle)-import Sarsi (Broker(..), Topic(..), createSocket, getSockAddr)+import Sarsi (Broker (..), Topic (..), createSocket, getSockAddr) import System.FSNotify (eventPath, watchDir, withManager)-import System.IO (IOMode(ReadMode), hClose, hWaitForInput)+import System.IO (IOMode (ReadMode), hClose, hWaitForInput) import System.IO.Machine (IOSource, byChunkOf, sourceHandle)  consumeOrWait :: Topic -> (Maybe s -> IOSource Event -> IO (Either s a)) -> IO a consumeOrWait topic@(Topic (Broker bp) tp) f = do   res <- consume topic f   either (const $ withManager waitAndRetry) return res-    where-      waitAndRetry mng = do-        lck <- newEmptyMVar-        stop <- watchDir mng bp pred' $ const $ putMVar lck ()-        takeMVar lck-        stop-        consumeOrWait topic f-      pred' e = eventPath e == tp+  where+    waitAndRetry mng = do+      lck <- newEmptyMVar+      stop <- watchDir mng bp pred' $ const $ putMVar lck ()+      takeMVar lck+      stop+      consumeOrWait topic f+    pred' e = eventPath e == tp  consume :: Topic -> (Maybe s -> IOSource Event -> IO (Either s a)) -> IO (Either IOException a) consume topic f = try $ consume' topic f@@ -32,13 +33,14 @@ consume' topic f = bracket createHandle hClose (process Nothing)   where     createHandle = do-      sock  <- createSocket+      sock <- createSocket       connect sock $ getSockAddr topic       socketToHandle sock ReadMode     process s h = do-      sa  <- f s $ asParts <~ auto unpack <~ processGet getEvent <~ sourceHandle (byChunkOf 1) h-      _   <- hWaitForInput h (-1)+      sa <- f s $ asParts <~ auto unpack <~ streamGet getEvent <~ sourceHandle (byChunkOf 1) h+      _ <- hWaitForInput h (-1)       either (continue h) return sa-        where continue h' s' = process (Just s') h'+      where+        continue h' s' = process (Just s') h'     unpack (Right e) = [e]     unpack (Left _) = []
+ src/Sarsi/Processor.hs view
@@ -0,0 +1,52 @@+module Sarsi.Processor where++import qualified Codec.GHC.Log as GHC+import Codec.Sarsi (Message)+import Codec.Sarsi.GHC (fromGHCLog)+import qualified Codec.Sarsi.Rust as Rust+import Data.Attoparsec.Text.Machine (streamParser)+import Data.Machine (ProcessT, asParts, auto, flattened, (<~))+import Data.Machine.Fanout (fanout)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Rosetta (LanguageTag (..), ProjectTag, projectLanguages)++data Processor = Processor {language :: LanguageTag, process :: ProcessT IO Text Message}++instance Eq Processor where+  a == b = (language a) == (language b)++instance Ord Processor where+  compare a b = compare (language a) (language b)++projectProcessors :: ProjectTag -> Set Processor+-- projectProcessors DOTNET = processDotnet+projectProcessors project = Set.fromList $ g =<< f <$> projectLanguages project+  where+    f l = (\p -> (l, p)) <$> languageProcess l+    g (Just (l, p)) = [Processor {language = l, process = p}]+    g Nothing = []++languageProcess :: LanguageTag -> Maybe (ProcessT IO Text Message)+languageProcess HS = Just processHaskell+languageProcess RS = Just processRust+languageProcess _ = Nothing++processAll :: [ProcessT IO Text Message] -> ProcessT IO Text Message+processAll xs = flattened <~ (fanout $ (\p -> (auto (\x -> [x])) <~ p) <$> xs)++processAny :: ProcessT IO Text Message+processAny = processAll [processHaskell, processRust]++processHaskell :: ProcessT IO Text Message+processHaskell = asParts <~ auto unpack <~ streamParser GHC.messageParser+  where+    unpack (Right msg) = [fromGHCLog msg]+    unpack (Left _) = []++processRust :: ProcessT IO Text Message+processRust = asParts <~ auto unpack <~ streamParser Rust.messageParser+  where+    unpack (Right msg) = [msg]+    unpack (Left _) = []
src/Sarsi/Producer.hs view
@@ -1,67 +1,97 @@ {-# LANGUAGE Rank2Types #-}+ module Sarsi.Producer where -import Codec.Sarsi (Event(Start), putEvent)-import Control.Exception (IOException, bracket, tryJust)+import Codec.Sarsi (Event (..), Level (..), Message (..), putEvent) import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Chan (dupChan, newChan, readChan, writeChan) import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (newTQueue, tryReadTQueue, writeTQueue)+import Control.Exception (IOException, bracket, tryJust) import Data.Binary.Machine (processPut)-import Data.Machine (ProcessT, (<~), runT_, sinkPart_, prepended)+import Data.List (foldl')+import Data.Machine (ProcessT, prepended, runT_, (<~))+import Data.Machine.Process (takingJusts) import Network.Socket (Socket, accept, bind, close, listen, socketToHandle)-import Sarsi (Topic, createSocket, createSockAddr, removeTopic)-import System.IO (IOMode(WriteMode), Handle, hClose)-import System.IO.Machine (byChunk, sinkIO, sinkHandle, sourceIO)+import Sarsi (Topic, createSockAddr, createSocket, removeTopic, title)+import System.Console.ANSI+import System.IO (Handle, IOMode (WriteMode), hClose)+import System.IO.Machine (byChunk, sinkHandle, sinkIO, sourceIO) +finishPrint :: Int -> Int -> IO ()+finishPrint e w = do+  setSGR (sgr e w)+  putStr $ title+  setSGR [Reset]+  putStr $ ": "+  putStrLn $ show event+  where+    sgr 0 0 = [SetColor Foreground Dull Green]+    sgr 0 _ = [SetColor Foreground Dull Yellow]+    sgr _ _ = [SetColor Foreground Vivid Red]+    event = Finish e w++finishCreate :: [Event] -> (Int, Int)+finishCreate xs = foldl' f empty xs+  where+    empty = (0, 0)+    f (e, w) (Notify (Message _ Warning _)) = (e, (w + 1))+    f (e, w) (Notify (Message _ Error _)) = ((e + 1), w)+    f finish _ = finish+ produce :: Topic -> (ProcessT IO Event Event -> IO a) -> IO a produce t f = do-  conns   <- atomically $ newTQueue-  chan    <- newChan-  state   <- newMVar []-  server  <- async $ bracket bindSock close (serve (process conns chan state))-  feeder  <- async $ f $ sinkPart_ (\x -> (x, x)) (sinkIO $ feed chan state)-  a       <- wait feeder+  conns <- atomically $ newTQueue+  chan <- newChan+  state <- newMVar []+  server <- async $ bracket bindSock close (serve (process conns chan state))+  feeder <- async $ f (sinkIO $ feed chan state)+  a <- wait feeder+  es <- readMVar state+  let (errs, warns) = finishCreate es+  writeChan chan $ Just $ Finish errs warns+  writeChan chan $ Nothing+  finishPrint errs warns   waitFinish conns   cancel server   removeTopic t   return a-    where-      bindSock = do-        sock  <- createSocket-        addr  <- createSockAddr t-        bind sock addr-        listen sock 1-        return sock-      process conns chan' state h = do-        chan <- dupChan chan'-        es   <- readMVar state-        conn <- async $ do-          runT_ $ sinkHandle byChunk h <~ processPut putEvent <~ (prepended $ reverse es) <~ (sourceIO $ readChan chan)-          hClose h-        atomically $ writeTQueue conns conn-        return Nothing-      feed chan state e = do-        modifyMVar_ state $ case e of-          (Start _) -> const $ return [e]-          _         -> return . (:) e-        writeChan chan e-      waitFinish conns = do-        conn <- atomically $ tryReadTQueue conns-        _    <- tryJust io $ maybe (return ()) wait conn-        return ()-          where-            io :: IOException -> Maybe ()-            io _ = Just ()+  where+    bindSock = do+      sock <- createSocket+      addr <- createSockAddr t+      bind sock addr+      listen sock 1+      return sock+    process conns chan' state h = do+      chan <- dupChan chan'+      es <- readMVar state+      conn <- async $ do+        runT_ $ sinkHandle byChunk h <~ processPut putEvent <~ (prepended $ reverse es) <~ takingJusts <~ (sourceIO $ readChan chan)+        hClose h+      atomically $ writeTQueue conns conn+      return Nothing+    feed chan state e = do+      modifyMVar_ state $ case e of+        (Start _) -> const $ return [e]+        _ -> return . (:) e+      writeChan chan $ Just e+    waitFinish conns = do+      conn <- atomically $ tryReadTQueue conns+      _ <- tryJust io $ maybe (return ()) wait conn+      return ()+      where+        io :: IOException -> Maybe ()+        io _ = Just ()  serve :: (Handle -> IO (Maybe a)) -> Socket -> IO a serve f sock = bracket acceptHandle hClose process   where     acceptHandle = do       (conn, _) <- accept sock-      h         <- socketToHandle conn WriteMode+      h <- socketToHandle conn WriteMode       return h     process h = do-      a         <- f h+      a <- f h       maybe (serve f sock) return a
+ src/Sarsi/Tools/Pipe.hs view
@@ -0,0 +1,40 @@+module Sarsi.Tools.Pipe where++import Codec.Sarsi (Event (..), Message (..))+import Codec.Sarsi.Curses (cleanLine, cleaningCurses)+import Data.Attoparsec.Text.Machine (processParser)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as ByteString+import Data.Machine (MachineT, ProcessT, asParts, auto, autoM, prepended, runT_, (<~))+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)+import Sarsi (getBroker, getTopic)+import Sarsi.Producer (produce)+import System.Exit (ExitCode (ExitSuccess), exitWith)+import System.IO (stdin, stdout)+import System.IO.Machine (byLine, sourceHandle)++pipe :: String -> ProcessT IO Text Message -> IO ()+pipe lbl process =+  pipeFrom lbl process $+    autoM echo <~ (sourceHandle byLine stdin)+  where+    echo xs = ByteString.hPutStrLn stdout xs >> return xs++pipeFrom :: String -> ProcessT IO Text Message -> MachineT IO k ByteString -> IO ()+pipeFrom lbl process source = do+  b <- getBroker+  t <- getTopic b "."+  produce t $ producer lbl process source+  exitWith ExitSuccess++producer :: String -> ProcessT IO Text Message -> MachineT IO k ByteString -> ProcessT IO Event Event -> IO ()+producer lbl process source sink = do+  runT_ $ pipeline <~ process <~ cleaning <~ auto decodeUtf8 <~ source+  where+    pipeline = sink <~ prepended [Start $ Text.pack lbl] <~ auto Notify+    cleaning = asParts <~ auto unpack <~ processParser cleaningCurses <~ auto (\txt -> (cleanLine txt) `Text.snoc` '\n')+      where+        unpack (Right (_, txt)) = [txt]+        unpack (Left _) = []
− src/Sarsi/Tools/Shell.hs 
@@ -1,61 +0,0 @@-module Sarsi.Tools.Shell where--import Codec.Sarsi (Event(..), Level(..), Message(..))-import Data.Machine (ProcessT, Is, (<~), auto, autoM, prepended, runT, runT_, source, wye, repeatedly, awaits, yield, Y(Z))-import Data.List (foldl')-import Data.Text (Text)-import Sarsi (getBroker, getTopic)-import Sarsi.Producer (produce)-import System.Environment (getArgs)-import System.IO (stderr, stdout)-import System.IO.Machine (byLine)-import System.Process (StdStream(..), shell, std_in, std_err, std_out)-import System.Process.Machine (ProcessMachines, callProcessMachines)-import System.Exit (ExitCode, exitWith)--import qualified Data.List as List-import qualified Data.Text as Text-import qualified Data.Text.IO as TextIO-import qualified Sarsi as Sarsi---- TODO Contribute to machine-process (as alt to mStdErr, mStdOut)-mStdOutputs :: ProcessT IO (Either a a) b -> ProcessMachines a a0 (Is a0) -> IO [b]-mStdOutputs mp (_, Just stdOut, Just stdErr)  = runT $ mp <~ wye stdErr stdOut slurp where-  slurp = repeatedly $ do-    res <- awaits Z-    yield res-mStdOutputs _  _                              = return []--callShell :: String -> ProcessT IO Text Message -> ProcessT IO Message a -> IO (ExitCode, [a])-callShell cmd parser sink = callProcessMachines byLine createProc (mStdOutputs pipeline)-  where-    pipeline    = sink <~ parser <~ appendCR <~ echo-    echo        = autoM $ \res -> case res of-      Left  txt -> TextIO.hPutStrLn stderr txt >> return txt-      Right txt -> TextIO.hPutStrLn stdout txt >> return txt-    createProc  = (shell cmd) { std_in = Inherit, std_err = CreatePipe, std_out = CreatePipe }-    appendCR    = auto $ (`Text.snoc` '\n')--producer :: String -> String -> ProcessT IO Text Message -> ProcessT IO Event Event -> IO ExitCode-producer lbl cmd parser sink = do-  (ec, xs) <- callShell cmd parser pipeline-  let finish = createFinish xs-  putStrLn $ concat [Sarsi.title, ": ", show finish]-  runT_ $ sink <~ source [finish]-  return ec-    where-      pipeline = sink <~ prepended [Start $ Text.pack lbl] <~ auto Notify-      createFinish xs = foldl' f empty xs-        where-          empty = Finish 0 0-          f (Finish e w) (Notify (Message _ Warning _)) = Finish e (w + 1)-          f (Finish e w) (Notify (Message _ Error _))   = Finish (e + 1) w-          f finish _ = finish--mainShell :: String -> ProcessT IO Text Message -> IO ()-mainShell lbl parser = do-  args  <- getArgs-  b     <- getBroker-  t     <- getTopic b "."-  ec    <- produce t $ producer lbl (concat $ List.intersperse " " args) parser-  exitWith ec
src/Sarsi/Tools/Trace.hs view
@@ -1,15 +1,29 @@ module Sarsi.Tools.Trace where -import Data.Machine ((<~), auto, runT_)+import qualified Codec.GHC.Log as GHC+import Codec.Sarsi.Curses (cleanLine, cleaningCurses)+import qualified Codec.Sarsi.Rust as Rust+import qualified Codec.Sarsi.SBT as SBT+import qualified Codec.Sarsi.SBT.Machine as SBTM import Data.Attoparsec.Text (Parser) import Data.Attoparsec.Text.Machine (streamParser)+import Data.Machine (ProcessT, asParts, auto, autoM, runT_, (<~))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO import System.IO (Handle) import System.IO.Machine (byLine, printer, sourceHandle) -import qualified Codec.GHC.Log as GHC-import qualified Codec.Sarsi.Rust as Rust-import qualified Codec.Sarsi.SBT as SBT-import qualified Data.Text as Text+traceCleanCurses :: Handle -> IO ()+traceCleanCurses h = runT_ $ autoM printing <~ preprocessing <~ appendLF <~ sourceHandle byLine h+  where+    printing (Right s) = TextIO.putStrLn s+    printing e = putStrLn $ show e+    preprocessing = streamParser cleaningCurses <~ asParts <~ auto unpackLine <~ asLines+      where+        asLines = streamParser $ SBT.untilLineBreak <* SBT.end+    unpackLine (Right txt) = [(cleanLine txt) `Text.snoc` '\n']+    unpackLine (Left _) = []  traceHS :: Handle -> IO () traceHS = traceParser GHC.messageParser@@ -20,10 +34,12 @@ traceSBT :: Handle -> IO () traceSBT = traceParser SBT.eventParser +traceSBTCurses :: Handle -> IO ()+traceSBTCurses h = runT_ $ printer <~ SBTM.eventProcess' <~ appendLF <~ sourceHandle byLine h+ traceParser :: Show a => Parser a -> Handle -> IO () traceParser parser h = do-  runT_ $ printer <~ streamParser parser <~ appendCR <~ sourceHandle byLine h-    where-      appendCR = auto $ (`Text.snoc` '\n')-+  runT_ $ printer <~ streamParser parser <~ appendLF <~ sourceHandle byLine h +appendLF :: ProcessT IO Text Text+appendLF = auto $ (`Text.snoc` '\n')