sarsi (empty) → 0.0.0.0
raw patch · 20 files changed
+961/−0 lines, 20 filesdep +attoparsecdep +basedep +binarysetup-changed
Dependencies added: attoparsec, base, binary, bytestring, containers, cryptonite, directory, filepath, fsnotify, machines, machines-binary, machines-io, machines-process, msgpack, network, process, sarsi, text, unordered-containers, vector
Files
- LICENSE +202/−0
- Setup.hs +2/−0
- sarsi-hs/Main.hs +57/−0
- sarsi-nvim/Data/MessagePack/RPC.hs +49/−0
- sarsi-nvim/Main.hs +56/−0
- sarsi-nvim/NVIM/Client.hs +40/−0
- sarsi-sbt/Main.hs +41/−0
- sarsi.cabal +121/−0
- sarsi/Main.hs +14/−0
- src/Codec/GHC/Log.hs +33/−0
- src/Codec/Sarsi.hs +70/−0
- src/Codec/Sarsi/GHC.hs +16/−0
- src/Codec/Sarsi/SBT.hs +67/−0
- src/Codec/Sarsi/SBT/Machine.hs +46/−0
- src/Data/Attoparsec/Machine.hs +20/−0
- src/Data/Attoparsec/Text/Machine.hs +13/−0
- src/Sarsi.hs +36/−0
- src/Sarsi/Consumer.hs +27/−0
- src/Sarsi/Producer.hs +26/−0
- src/Sarsi/Trace.hs +25/−0
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2016 Alois Cochard++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sarsi-hs/Main.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE Rank2Types #-}+module Main where++import Codec.GHC.Log (messageParser)+import Codec.Sarsi (Event(..), Level(..), Message(..))+import Codec.Sarsi.GHC (fromGHCLog)+import Data.Attoparsec.Text.Machine (streamParser)+import Data.Machine (ProcessT, (<~), asParts, auto, autoM, before, echo, prepended, runT_, source)+import Data.Machine.Plan (yield)+import Data.List (foldl')+import Sarsi.Producer (produce)+import System.Environment (getArgs)+import System.IO (stdin, stdout, stderr)+import System.IO.Machine (byLine, printer)+import System.Process (CreateProcess, StdStream(..), shell, std_in, std_out, std_err)+import System.Process.Machine (callProcessMachines, mStdErr)+import System.Exit (ExitCode)++import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO+import qualified Sarsi as Sarsi++title :: String+title = concat [Sarsi.title, "-hs"]++-- TODO Use Wee/Tee to merge stdout/stderr (keep echoText splitted).+callShell :: String -> ProcessT IO Message a -> IO (ExitCode, [a])+callShell cmd sink = callProcessMachines byLine createProc (mStdErr pipeline)+ where+ pipeline = sink <~ asParts <~ auto unpack <~ streamParser messageParser <~ echoText stderr <~ appendCR+ unpack (Right msg) = [fromGHCLog msg]+ unpack (Left _) = []+ echoText h = autoM $ (\txt -> TextIO.hPutStr h txt >> return txt)+ createProc = (shell cmd) { std_in = Inherit, std_err = CreatePipe }+ appendCR = auto $ (`Text.snoc` '\n')++producer :: String -> ProcessT IO Event Event -> IO ()+producer cmd sink = do+ (ec, xs) <- callShell cmd pipeline+ let finish = createFinish xs+ putStrLn $ concat [title, ": ", show finish]+ runT_ $ sink <~ source [finish]+ return ()+ where+ pipeline = sink <~ prepended [Start $ Text.pack "haskell"] <~ auto Notify+ createFinish xs = foldl' f empty xs+ where+ empty = Finish 0 0+ f (Finish w e) (Notify (Message _ Warning _)) = Finish (w + 1) e+ f (Finish w e) (Notify (Message _ Error _)) = Finish w (e + 1)+ f finish _ = finish++main :: IO ()+main = do+ args <- getArgs+ produce "." $ producer (concat $ List.intersperse " " args)
+ sarsi-nvim/Data/MessagePack/RPC.hs view
@@ -0,0 +1,49 @@+module Data.MessagePack.RPC where++import Data.Binary (Get, Put, get, getWord8, put)+import Data.MessagePack (Object(..))+import Data.Text (Text)+import Data.Vector (Vector)++import qualified Data.MessagePack as MP+import qualified Data.Vector as Vector++data Answer = Success Object | Error Object+ deriving Show++data Request = Request+ { requestMessageID :: Int+ , requestMethod :: Text+ , requestParams :: Vector Object }+ deriving Show++putRequest :: Request -> Put+putRequest (Request msgID method params) =+ MP.putArray id $ Vector.fromList $ [MP.putInt 0, MP.putInt msgID, MP.putStr method, MP.putArray put params]++data Message+ = Response+ { responseMessageID :: Int+ , responseAnswer :: Answer }+ | Notification+ { notificationMethod :: Text+ , notificationParams :: Vector Object }+ deriving Show++getMessage :: Get Message+getMessage = do+ _ <- getWord8+ tpe <- MP.getInt+ case tpe of+ 1 -> do+ id <- MP.getInt+ err <- get+ res <- get+ return $ Response id $ f err res where+ f ObjectNil res = Success res+ f err ObjectNil = Error err+ 2 -> do+ method <- MP.getStr+ (ObjectArray params) <- get+ return $ Notification method params+ _ -> fail "unsupported message type"
+ sarsi-nvim/Main.hs view
@@ -0,0 +1,56 @@+module Main where++import Codec.Sarsi (Event(..), Level(..), Location(..), Message(..), getEvent)+import Data.Machine ((<~), asParts, auto, scan)+import Data.MessagePack.Object (Object(..), toObject)+import NVIM.Client (Command(..), runCommand)+import Sarsi (title)+import Sarsi.Consumer (consume)+import System.IO (BufferMode(NoBuffering), hSetBinaryMode, hSetBuffering, stdin, stdout)+import System.IO.Machine (sinkIO)++import qualified Data.Text as Text+import qualified Data.Map as Map+import qualified Data.Vector as Vector++echo :: String -> Command+echo str = VimCommand [toObject $ concat ["echo \"", str, "\""]]++echom :: String -> Command+echom str = VimCommand [toObject $ concat ["echom \"", title, ": ", str, "\""]]++setqflist :: String -> [Object] -> Command+setqflist action items = VimCallFunction (Text.pack "setqflist") [toObject items, toObject action]++-- TODO Sanitize text description by escaping special characters+mkQuickFix :: Message -> Object+mkQuickFix (Message (Location fp col ln) lvl txts) = toObject . Map.fromList $+ [ ("filename", toObject fp)+ , ("lnum", ObjectInt ln)+ , ("col", ObjectInt col)+ , ("type", toObject $ tpe lvl)+ , ("text", toObject $ Text.unlines $ Vector.toList txts) ]+ where+ tpe Error = "E"+ tpe Warning = "W"++convert :: Bool -> Event -> (Bool, [Command])+convert _ e@(Start _) = (True, [echom $ show e])+convert _ e@(Finish _ _) = (True, [echom $ show e])+convert first (Notify msg@(Message loc lvl _)) = (False, xs) where+ xs =+ [ setqflist (if first then "r" else "a") [mkQuickFix msg]+ , echo $ concat [show loc, " ", show lvl] ]++main :: IO ()+main = do+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ consume "." $ sinkIO publish <~ asParts <~ auto unpack <~ scan f (True, [])+ where+ f (first, _) event = convert first event+ unpack (_, xs) = xs+ publish cmd = do+ -- TODO Log failed command in a file (or print to stderr?).+ _ <- runCommand cmd+ return ()
+ sarsi-nvim/NVIM/Client.hs view
@@ -0,0 +1,40 @@+module NVIM.Client where++-- | A primitive NVIM RPC synchronous client.++import Data.Binary.Get (runGet)+import Data.Binary.Machine (streamGet)+import Data.Binary.Put (runPut)+import Data.ByteString (hGetSome, hPut)+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Machine ((<~), asParts, auto, final, run, source)+import Data.MessagePack.Object (Object(..), toObject)+import Data.MessagePack.RPC (Answer(..), Request(..), Message(..), getMessage, putRequest)+import Data.Text (Text)+import System.IO (Handle, stdin, stdout)++import qualified Data.Text as Text+import qualified Data.Vector as Vector++data Command = VimCommand [Object] | VimCallFunction Text [Object]++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+ xs <- hGetSome hIn 1024+ let ys = run $ final <~ asParts <~ auto unpack <~ 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") $ Vector.fromList xs+ mkRequest (VimCallFunction m xs) =+ Request 0 (Text.pack "vim_call_function") $ Vector.fromList $+ [ toObject m+ , toObject $ Vector.fromList xs ]+ unpack (Response _ a) = [a]+ unpack _ = []
+ sarsi-sbt/Main.hs view
@@ -0,0 +1,41 @@+module Main where++import Codec.Sarsi (Event)+import Codec.Sarsi.SBT.Machine (eventProcess)+import Data.Machine (ProcessT, (<~), asParts, auto, autoM, runT_)+import Sarsi.Producer (produce)+import System.Environment (getArgs)+import System.Exit (ExitCode)+import System.Process (CreateProcess, StdStream(..), shell, std_in, std_out, std_err)+import System.Process.Machine (callProcessMachines, mStdOut)+import System.IO (BufferMode(NoBuffering), hSetBuffering, stdin, stdout)+import System.IO.Machine (byChunk, printer)++import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO+import qualified Sarsi as Sarsi++title :: String+title = concat [Sarsi.title, "-sbt"]++callShell :: String -> ProcessT IO Event a -> IO (ExitCode, [a])+callShell cmd sink = callProcessMachines byChunk createProc (mStdOut pipeline)+ 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 }++producer :: String -> ProcessT IO Event Event -> IO ()+producer cmd sink = do+ (ec, _) <- callShell cmd sink+ putStrLn $ concat [title, ": ", show ec]+ return ()++main :: IO ()+main = do+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ args <- getArgs+ produce "." $ producer $ concat $ List.intersperse " " ("sbt":args)
+ sarsi.cabal view
@@ -0,0 +1,121 @@+name: sarsi+version: 0.0.0.0+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+author: Alois Cochard+maintainer: alois.cochard@gmail.com+category: Development+build-type: Simple+cabal-version: >=1.10++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules:+ Codec.Sarsi+ Codec.Sarsi.GHC+ Codec.Sarsi.SBT+ Codec.Sarsi.SBT.Machine+ Sarsi+ Sarsi.Consumer+ Sarsi.Producer+ Sarsi.Trace+ -- TODO Extract in a `codec-ghc-log` module+ 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+ , attoparsec >= 0.12 && < 0.14+ , binary >= 0.7 && < 0.9+ , bytestring >= 0.10 && < 0.11+ , containers >= 0.5 && < 0.6+ , cryptonite >= 0.10 && < 0.14+ , directory >= 1.2 && < 1.3+ , filepath >= 1.4 && < 1.5+ , 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+ , msgpack >= 1.0 && < 1.1+ , network >= 2.6 && < 2.7+ , process >= 1.1 && < 1.5+ , text >= 1.2 && < 1.3+ , vector >= 0.10 && < 0.12++executable sarsi + main-is: Main.hs+ build-depends: + base+ , sarsi+ hs-source-dirs: sarsi+ ghc-options: -Wall+ default-language: Haskell2010+++executable sarsi-hs+ main-is: Main.hs+ other-modules:+ build-depends: + base+ , sarsi+ , machines+ , machines-io+ , machines-process+ , process+ , text+ , fsnotify >= 0.2 && < 0.3+ hs-source-dirs: sarsi-hs+ ghc-options: -Wall -dynamic+ default-language: Haskell2010++executable sarsi-nvim+ main-is: Main.hs+ other-modules:+ -- TODO Extract in a mspgack specific packages.+ -- Data.MessagePack.ToJSON+ Data.MessagePack.RPC+ -- TODO Extract in a lightweight nvim client.+ NVIM.Client+ -- NVIM.Info+ build-depends: + base+ , sarsi+ , binary+ , bytestring+ , containers+ , machines+ , machines-binary+ , machines-io+ , msgpack+ , network+ , process+ , text+ , vector+ , unordered-containers >= 0.2 && < 0.3+ hs-source-dirs: sarsi-nvim+ ghc-options: -Wall -dynamic+ default-language: Haskell2010++executable sarsi-sbt+ main-is: Main.hs+ other-modules:+ build-depends: + base+ , sarsi+ , machines+ , machines-io+ , machines-process+ , process+ , text+ hs-source-dirs: sarsi-sbt+ ghc-options: -Wall -dynamic+ default-language: Haskell2010
+ sarsi/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import Sarsi (mkSockAddr)+import Sarsi.Trace (traceHS, traceSBT)+import System.IO (stdin)+import System.Environment (getArgs)++main :: IO ()+main = getArgs >>= run where+ run ["--trace-hs"] = traceHS stdin+ run ["--trace-sbt"] = traceSBT stdin+ run [] = do+ sock <- mkSockAddr "."+ print sock
+ src/Codec/GHC/Log.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Codec.GHC.Log where++import Data.Attoparsec.Text+import Data.Text (Text)++data Message = Message Text Pos Level [Text]+ deriving Show++data Pos = Pos { column :: Int, line :: Int }+ deriving Show++data Level = Warning | Error+ deriving Show++messageParser :: Parser Message+messageParser = do+ fp <- takeWhile1 (\c -> c /= sepChar && c /= '\n' && c /= '\r') <* char sepChar+ n <- decimal <* char sepChar+ c <- decimal <* char sepChar+ l <- choice+ [ string " Warning:" *> return Warning+ , return Error ]+ txt <- choice+ [ return <$> untilLineBreak <* ("\n" <* end)+ , takeLineBreak *> (multilinesComment <* end) ]+ return $ Message fp (Pos c n) l txt+ where+ multilinesComment = many1 $ (" " *> (untilLineBreak <* "\n"))+ untilLineBreak = takeWhile1 $ \w -> w /= '\n' && w /= '\r'+ takeLineBreak = takeWhile1 $ \w -> w == '\n' || w == '\r'+ end = choice [const () <$> "\n", endOfInput, return ()]+ sepChar = ':'
+ src/Codec/Sarsi.hs view
@@ -0,0 +1,70 @@+module Codec.Sarsi where++import Data.Text (Text, unpack)+import Data.Binary (Get, Put)+import Data.Vector (Vector)++import qualified Data.MessagePack.Get as Get+import qualified Data.MessagePack.Put as Put+import qualified Data.Text as Text+import qualified Data.Vector as Vector++data Event+ = Start { label :: Text }+ | Finish { errors :: Int, warnings :: Int }+ | Notify { message :: Message }++instance Show Event where+ show (Start label) = concat ["starting ", unpack label, " build"]+ show (Finish 0 0) = "build success"+ show (Finish w 0) = concat ["build success with ", show w, " warning(s)"]+ show (Finish 0 e) = concat ["build fail with ", show e, " error(s)"]+ show (Finish w e) = concat ["build fail with ", show e, " error(s) and ", show w, " warning(s)"]+ show (Notify msg) = concat ["message=", show msg]++getEvent :: Get Event+getEvent = do+ tpe <- Get.getInt+ case tpe of+ 0 -> Start <$> Get.getStr+ 1 -> Finish <$> Get.getInt <*> Get.getInt+ 2 -> Notify <$> getMessage+ _ -> fail "unsupported event type"++putEvent :: Event -> Put+putEvent (Start t) = Put.putInt 0 *> Put.putStr t+putEvent (Finish es ws) = Put.putInt 1 *> Put.putInt es *> Put.putInt ws+putEvent (Notify m) = Put.putInt 2 *> putMessage m++data Message = Message Location Level (Vector Text)++instance Show Message where+ show (Message loc lvl txts) =+ (concat [show loc, " ", show lvl, "\n"]) ++ (unlines $ Text.unpack <$> Vector.toList txts)++getMessage :: Get Message+getMessage = Message <$> getLocation <*> getLevel <*> Get.getArray Get.getStr++putMessage :: Message -> Put+putMessage (Message loc lvl txt) = putLocation loc *> putLevel lvl *> Put.putArray Put.putStr txt++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]++getLocation :: Get Location+getLocation = Location <$> Get.getStr <*> Get.getInt <*> Get.getInt++putLocation :: Location -> Put+putLocation (Location fp c l) = Put.putStr fp *> Put.putInt c *> Put.putInt l++data Level = Warning | Error+ deriving (Enum, Show)++getLevel :: Get Level+getLevel = fmap toEnum Get.getInt++putLevel :: Level -> Put+putLevel = Put.putInt . fromEnum+
+ src/Codec/Sarsi/GHC.hs view
@@ -0,0 +1,16 @@+module Codec.Sarsi.GHC where++import Codec.Sarsi+import Data.Text (Text, strip)++import qualified Codec.GHC.Log as Log+import qualified Data.Vector as Vector++fromGHCLog :: Log.Message -> Message+fromGHCLog (Log.Message fp (Log.Pos col ln) lvl texts) =+ Message (Location (strip fp) col ln) (fromGHCLevel lvl) (Vector.fromList $ strip <$> texts)++fromGHCLevel :: Log.Level -> Level+fromGHCLevel Log.Warning = Warning+fromGHCLevel Log.Error = Error+
+ src/Codec/Sarsi/SBT.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+module Codec.Sarsi.SBT where++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 qualified Data.Text as Text+import qualified Data.Vector as Vector++data SBTEvent = CompileStart Text | TaskFinish Bool Text | Throw Message+ deriving Show++eventParser :: Parser SBTEvent+eventParser = choice [compile, finish, Throw <$> messageParser]+ where+ compile = do+ txt <- string "[info] Compiling " *> untilLineBreak <* end+ return $ CompileStart txt+ finish = do+ res <- status <* space+ txt <- string "Total time: " *> untilLineBreak <* end+ _ <- end+ return $ TaskFinish res txt+ 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 (col + 1) ln) lvl $ formatTxts t ts+ where+ takeLineBreak = takeWhile1 $ \w -> w == '\n' || w == '\r'+ level = choice [string "[error]" *> return Error, string "[warn]" *> return Warning]+ lineStart = level <* space+ sepChar = ':'+ formatTxts t [] = Vector.singleton t+ formatTxts t ts = Vector.fromList $ t : init ts+ column = lineStart *> ((length <$> many1 space) <* "^\n")++cleanEC :: Parser Text+cleanEC = choice [noEC, withEC]+ 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++untilLineBreak = takeWhile1 $ \w -> w /= '\n' && w /= '\r'+end = choice [const () <$> "\n", endOfInput, return ()]+
+ src/Codec/Sarsi/SBT/Machine.hs view
@@ -0,0 +1,46 @@+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.Machine (ProcessT, (<~), asParts, auto, autoM, scan, runT_)+import Data.Text (Text)++import qualified Data.Text as Text++eventProcess :: Monad m => ProcessT m Text Event+eventProcess = asParts <~ auto unpack <~ (scan f (emptySession, Nothing)) <~ eventProcess'+ where+ f (session, _) event = runSession session event+ unpack (_, Just e) = [e]+ 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 _) = []+++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)+ where+ inc (Message _ Warning _) (e, w) = (e, w + 1)+ inc (Message _ Error _) (e, w) = (e + 1, w)
+ src/Data/Attoparsec/Machine.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE Rank2Types #-}+module Data.Attoparsec.Machine where++import Data.Attoparsec.Internal.Types (IResult(..), Parser)+import Data.Machine (MachineT(..), ProcessT, Step(Await, Yield), Is(Refl), source, 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)++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)
+ src/Data/Attoparsec/Text/Machine.hs view
@@ -0,0 +1,13 @@+module Data.Attoparsec.Text.Machine where++import Data.Attoparsec.Text (Parser, parse)+import Data.Text (Text)+import Data.Machine (ProcessT)++import Data.Attoparsec.Machine (processParserWith, streamParserWith)++streamParser :: Monad m => Parser a -> ProcessT m Text (Either String a)+streamParser p = streamParserWith $ parse p++processParser :: Monad m => Parser a -> ProcessT m Text (Either String (Text, a))+processParser p = processParserWith $ parse p
+ src/Sarsi.hs view
@@ -0,0 +1,36 @@+module Sarsi where++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, doesFileExist, makeAbsolute, removeFile)+import System.FilePath ((</>))++import qualified Data.ByteString.Char8 as BSC8++title :: String+title = "sarsi"++-- TODO Windows compat: create a TCP socket.++mkSocket :: IO Socket+mkSocket = do+ socket AF_UNIX Stream defaultProtocol++mkSockAddr :: FilePath -> IO SockAddr+mkSockAddr fp = do+ path <- getSockPath fp+ return . SockAddrUnix $ path++mkSockAddr' :: FilePath -> IO SockAddr+mkSockAddr' fp = do+ path <- getSockPath fp+ exists <- doesFileExist path+ if (exists) then removeFile path else return ()+ mkSockAddr fp++getSockPath :: FilePath -> IO FilePath+getSockPath fp' = do+ fp <- makeAbsolute fp'+ tmp <- getTemporaryDirectory+ return $ tmp </> concat [title, "-", show $ (hash $ BSC8.pack fp :: Digest MD5)]
+ src/Sarsi/Consumer.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Rank2Types #-}+module Sarsi.Consumer where++import Codec.Sarsi (Event, getEvent)+import Data.Binary.Machine (streamGet)+import Data.Machine ((<~), runT_)+import Network.Socket (Socket, accept, bind, listen, close, socketToHandle)+import Sarsi (mkSocket, mkSockAddr')+import System.IO (IOMode(ReadMode), hClose)+import System.IO.Machine (IOSink, byChunk, sourceHandle)++consume :: FilePath -> IOSink Event -> IO ()+consume fp sink = do+ sock <- mkSocket+ addr <- mkSockAddr' fp+ bind sock addr+ listen sock 1+ serve sock sink+ close sock++serve :: Socket -> IOSink Event -> IO ()+serve sock sink = do+ (conn, _) <- accept sock+ h <- socketToHandle conn ReadMode+ runT_ $ sink <~ streamGet getEvent <~ sourceHandle (byChunk) h+ hClose h+ serve sock sink
+ src/Sarsi/Producer.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Rank2Types #-}+module Sarsi.Producer where++import Codec.Sarsi (Event(..), putEvent)+import Data.Binary.Machine (processPut)+import Data.Machine (ProcessT, (<~), auto, asParts, runT_)+import Data.Machine.Fanout (fanout)+import Network.Socket (connect, socketToHandle)+import System.IO (IOMode(AppendMode), hClose)+import System.IO.Machine (byChunk, sinkHandle)++import qualified Data.Text as T++import Sarsi (mkSocket, mkSockAddr)++produce :: FilePath -> (ProcessT IO Event Event -> IO a) -> IO a+produce fp f = do+ sock <- mkSocket+ addr <- mkSockAddr fp+ connect sock addr+ h <- socketToHandle sock AppendMode+ -- TODO use sinkPart_+ res <- f $ asParts <~ fanout [auto (:[]), auto (const []) <~ sinkHandle byChunk h <~ processPut putEvent]+ hClose h+ return res+
+ src/Sarsi/Trace.hs view
@@ -0,0 +1,25 @@+module Sarsi.Trace where++import Data.Machine ((<~), auto, runT_)+import Data.Attoparsec.Text (Parser)+import Data.Attoparsec.Text.Machine (streamParser)+import System.IO (Handle)+import System.IO.Machine (byLine, printer, sourceHandle)++import qualified Codec.GHC.Log as GHC+import qualified Codec.Sarsi.SBT as SBT+import qualified Data.Text as Text++traceHS :: Handle -> IO ()+traceHS = traceParser GHC.messageParser++traceSBT :: Handle -> IO ()+traceSBT = traceParser SBT.eventParser++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')++