diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sarsi-hs/Main.hs b/sarsi-hs/Main.hs new file mode 100644 --- /dev/null +++ b/sarsi-hs/Main.hs @@ -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) diff --git a/sarsi-nvim/Data/MessagePack/RPC.hs b/sarsi-nvim/Data/MessagePack/RPC.hs new file mode 100644 --- /dev/null +++ b/sarsi-nvim/Data/MessagePack/RPC.hs @@ -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" diff --git a/sarsi-nvim/Main.hs b/sarsi-nvim/Main.hs new file mode 100644 --- /dev/null +++ b/sarsi-nvim/Main.hs @@ -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 () diff --git a/sarsi-nvim/NVIM/Client.hs b/sarsi-nvim/NVIM/Client.hs new file mode 100644 --- /dev/null +++ b/sarsi-nvim/NVIM/Client.hs @@ -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 _ = [] diff --git a/sarsi-sbt/Main.hs b/sarsi-sbt/Main.hs new file mode 100644 --- /dev/null +++ b/sarsi-sbt/Main.hs @@ -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) diff --git a/sarsi.cabal b/sarsi.cabal new file mode 100644 --- /dev/null +++ b/sarsi.cabal @@ -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 . + +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 diff --git a/sarsi/Main.hs b/sarsi/Main.hs new file mode 100644 --- /dev/null +++ b/sarsi/Main.hs @@ -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 diff --git a/src/Codec/GHC/Log.hs b/src/Codec/GHC/Log.hs new file mode 100644 --- /dev/null +++ b/src/Codec/GHC/Log.hs @@ -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 = ':' diff --git a/src/Codec/Sarsi.hs b/src/Codec/Sarsi.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Sarsi.hs @@ -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 + diff --git a/src/Codec/Sarsi/GHC.hs b/src/Codec/Sarsi/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Sarsi/GHC.hs @@ -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 + diff --git a/src/Codec/Sarsi/SBT.hs b/src/Codec/Sarsi/SBT.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Sarsi/SBT.hs @@ -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 ()] + diff --git a/src/Codec/Sarsi/SBT/Machine.hs b/src/Codec/Sarsi/SBT/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Sarsi/SBT/Machine.hs @@ -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) diff --git a/src/Data/Attoparsec/Machine.hs b/src/Data/Attoparsec/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Data/Attoparsec/Machine.hs @@ -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) diff --git a/src/Data/Attoparsec/Text/Machine.hs b/src/Data/Attoparsec/Text/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Data/Attoparsec/Text/Machine.hs @@ -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 diff --git a/src/Sarsi.hs b/src/Sarsi.hs new file mode 100644 --- /dev/null +++ b/src/Sarsi.hs @@ -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)] diff --git a/src/Sarsi/Consumer.hs b/src/Sarsi/Consumer.hs new file mode 100644 --- /dev/null +++ b/src/Sarsi/Consumer.hs @@ -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 diff --git a/src/Sarsi/Producer.hs b/src/Sarsi/Producer.hs new file mode 100644 --- /dev/null +++ b/src/Sarsi/Producer.hs @@ -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 + diff --git a/src/Sarsi/Trace.hs b/src/Sarsi/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Sarsi/Trace.hs @@ -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') + +