sensei 0.8.0 → 0.9.0
raw patch · 37 files changed
+1925/−396 lines, 37 filesdep +http-conduitdep +http-mediadep +prettydep ~hspec
Dependencies added: http-conduit, http-media, pretty, vcr, wai-extra
Dependency ranges changed: hspec
Files
- LICENSE +1/−1
- driver/seito.hs +2/−1
- driver/sensei-web.hs +1/−4
- driver/sensei.hs +1/−4
- sensei.cabal +120/−16
- src/Client.hs +18/−29
- src/Config.hs +9/−8
- src/Config/DeepSeek.hs +16/−0
- src/DeepSeek.hs +174/−0
- src/DeepSeek/Types.hs +84/−0
- src/GHC/Diagnostic.hs +127/−0
- src/GHC/Diagnostic/Type.hs +106/−0
- src/HTTP.hs +115/−17
- src/HTTP/Util.hs +41/−0
- src/Imports.hs +55/−5
- src/Language/Haskell/GhciWrapper.hs +116/−45
- src/ReadHandle.hs +69/−9
- src/Run.hs +67/−41
- src/Sensei/API.hs +34/−0
- src/Session.hs +37/−16
- src/Trigger.hs +15/−25
- src/Util.hs +24/−6
- startup.ghci +0/−4
- test/ClientSpec.hs +25/−9
- test/ConfigSpec.hs +14/−2
- test/DeepSeekSpec.hs +51/−0
- test/EventQueueSpec.hs +1/−1
- test/GHC/DiagnosticSpec.hs +131/−0
- test/HTTPSpec.hs +158/−8
- test/Helper.hs +46/−19
- test/Language/Haskell/GhciWrapperSpec.hs +57/−7
- test/ReadHandleSpec.hs +119/−16
- test/RunSpec.hs +5/−5
- test/SessionSpec.hs +11/−23
- test/SpecHook.hs +29/−2
- test/TriggerSpec.hs +37/−72
- test/UtilSpec.hs +9/−1
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015-2016 Simon Hengel <sol@typeful.net>+Copyright (c) 2015-2025 Simon Hengel <sol@typeful.net> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
driver/seito.hs view
@@ -1,6 +1,7 @@ module Main (main) where import System.Exit+import System.Environment import Control.Monad import qualified Data.ByteString.Lazy as L @@ -8,6 +9,6 @@ main :: IO () main = do- (success, output) <- client ""+ (success, output) <- getArgs >>= client "" L.putStr output unless success exitFailure
driver/sensei-web.hs view
@@ -2,10 +2,7 @@ import System.Environment -import Paths_sensei import Run main :: IO ()-main = do- startupFile <- getDataFileName "startup.ghci"- getArgs >>= runWeb startupFile+main = getArgs >>= runWeb
driver/sensei.hs view
@@ -2,10 +2,7 @@ import System.Environment -import Paths_sensei import Run main :: IO ()-main = do- startupFile <- getDataFileName "startup.ghci"- getArgs >>= run startupFile+main = getArgs >>= run
sensei.cabal view
@@ -1,33 +1,104 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: sensei-version: 0.8.0+version: 0.9.0 synopsis: Automatically run Hspec tests on file modifications category: Development homepage: https://github.com/hspec/sensei#readme bug-reports: https://github.com/hspec/sensei/issues+author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net> license: MIT license-file: LICENSE build-type: Simple-data-files:- startup.ghci source-repository head type: git location: https://github.com/hspec/sensei +library+ exposed-modules:+ Sensei.API+ other-modules:+ Client+ Config+ Config.DeepSeek+ DeepSeek+ DeepSeek.Types+ EventQueue+ GHC.Diagnostic+ GHC.Diagnostic.Type+ HTTP+ HTTP.Util+ Imports+ Input+ Language.Haskell.GhciWrapper+ Options+ Pager+ ReadHandle+ Run+ Session+ Trigger+ Util+ hs-source-dirs:+ src+ default-extensions:+ DuplicateRecordFields+ LambdaCase+ NoFieldSelectors+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ ViewPatterns+ BlockArguments+ ghc-options: -Wall -threaded+ build-depends:+ aeson+ , ansi-terminal+ , async+ , base >=4.11 && <5+ , bytestring >=0.11+ , casing+ , containers+ , directory+ , filepath+ , fsnotify ==0.4.*+ , http-client >=0.5.0+ , http-conduit+ , http-media+ , http-types+ , mtl+ , network+ , pretty+ , process+ , stm+ , temporary+ , text+ , time+ , transformers+ , unix+ , wai+ , warp+ , yaml+ default-language: GHC2021+ executable seito main-is: seito.hs other-modules: Client Config+ Config.DeepSeek+ DeepSeek+ DeepSeek.Types EventQueue+ GHC.Diagnostic+ GHC.Diagnostic.Type HTTP+ HTTP.Util Imports Input Language.Haskell.GhciWrapper@@ -35,10 +106,10 @@ Pager ReadHandle Run+ Sensei.API Session Trigger Util- Paths_sensei hs-source-dirs: src driver@@ -50,8 +121,7 @@ OverloadedStrings RecordWildCards ViewPatterns- other-extensions:- NoFieldSelectors+ BlockArguments ghc-options: -Wall -threaded build-depends: aeson@@ -65,11 +135,15 @@ , filepath , fsnotify ==0.4.* , http-client >=0.5.0+ , http-conduit+ , http-media , http-types , mtl , network+ , pretty , process , stm+ , temporary , text , time , transformers@@ -84,8 +158,14 @@ other-modules: Client Config+ Config.DeepSeek+ DeepSeek+ DeepSeek.Types EventQueue+ GHC.Diagnostic+ GHC.Diagnostic.Type HTTP+ HTTP.Util Imports Input Language.Haskell.GhciWrapper@@ -93,10 +173,10 @@ Pager ReadHandle Run+ Sensei.API Session Trigger Util- Paths_sensei hs-source-dirs: src driver@@ -108,8 +188,7 @@ OverloadedStrings RecordWildCards ViewPatterns- other-extensions:- NoFieldSelectors+ BlockArguments ghc-options: -Wall -threaded build-depends: aeson@@ -123,11 +202,15 @@ , filepath , fsnotify ==0.4.* , http-client >=0.5.0+ , http-conduit+ , http-media , http-types , mtl , network+ , pretty , process , stm+ , temporary , text , time , transformers@@ -142,8 +225,14 @@ other-modules: Client Config+ Config.DeepSeek+ DeepSeek+ DeepSeek.Types EventQueue+ GHC.Diagnostic+ GHC.Diagnostic.Type HTTP+ HTTP.Util Imports Input Language.Haskell.GhciWrapper@@ -151,10 +240,10 @@ Pager ReadHandle Run+ Sensei.API Session Trigger Util- Paths_sensei hs-source-dirs: src driver@@ -166,8 +255,7 @@ OverloadedStrings RecordWildCards ViewPatterns- other-extensions:- NoFieldSelectors+ BlockArguments ghc-options: -Wall -threaded build-depends: aeson@@ -181,11 +269,15 @@ , filepath , fsnotify ==0.4.* , http-client >=0.5.0+ , http-conduit+ , http-media , http-types , mtl , network+ , pretty , process , stm+ , temporary , text , time , transformers@@ -201,8 +293,14 @@ other-modules: Client Config+ Config.DeepSeek+ DeepSeek+ DeepSeek.Types EventQueue+ GHC.Diagnostic+ GHC.Diagnostic.Type HTTP+ HTTP.Util Imports Input Language.Haskell.GhciWrapper@@ -210,12 +308,15 @@ Pager ReadHandle Run+ Sensei.API Session Trigger Util ClientSpec ConfigSpec+ DeepSeekSpec EventQueueSpec+ GHC.DiagnosticSpec Helper HTTPSpec Language.Haskell.GhciWrapperSpec@@ -227,7 +328,6 @@ SpecHook TriggerSpec UtilSpec- Paths_sensei hs-source-dirs: src test@@ -239,8 +339,7 @@ OverloadedStrings RecordWildCards ViewPatterns- other-extensions:- NoFieldSelectors+ BlockArguments ghc-options: -Wall -threaded cpp-options: -DTEST build-tool-depends:@@ -261,10 +360,13 @@ , hspec-contrib >=0.5.2 , hspec-wai , http-client >=0.5.0+ , http-conduit+ , http-media , http-types , mockery , mtl , network+ , pretty , process , stm , temporary@@ -272,7 +374,9 @@ , time , transformers , unix+ , vcr , wai+ , wai-extra , warp , yaml default-language: GHC2021
src/Client.hs view
@@ -1,35 +1,24 @@ module Client (client) where -import Imports+import Imports -import Network.HTTP.Client-import Network.HTTP.Client.Internal (Response(..))-import Network.HTTP.Types-import Network.Socket (connect)-import qualified Data.ByteString.Lazy as L+import System.IO+import Network.HTTP.Client -import HTTP (newSocket, socketAddr, socketName)+import HTTP.Util (makeRequest) -client :: FilePath -> IO (Bool, L.ByteString)-client dir = fromRight connectError <$> tryJust p go+client :: FilePath -> [String] -> IO (Bool, LazyByteString)+client dir args = case args of+ [] -> hIsTerminalDevice stdout >>= run+ ["--no-color"] -> run False+ ["--color"] -> run True+ _ -> do+ hPutStrLn stderr $ "Usage: seito [ --color | --no-color ]"+ return (False, "") where- connectError :: (Bool, L.ByteString)- connectError = (False, "could not connect to " <> fromString (socketName dir) <> "\n")-- p :: HttpException -> Maybe ()- p e = case e of- HttpExceptionRequest _ (ConnectionFailure se) -> guard (isDoesNotExistException se) >> Just ()- _ -> Nothing-- isDoesNotExistException :: SomeException -> Bool- isDoesNotExistException = maybe False isDoesNotExistError . fromException-- go = do- manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection}- Response{..} <- httpLbs "http://localhost/" manager- return (statusIsSuccessful responseStatus, responseBody)-- newConnection _ _ _ = do- sock <- newSocket- connect sock $ socketAddr dir- socketConnection sock 8192+ run :: Bool -> IO (Bool, LazyByteString)+ run color = do+ let+ url :: Request+ url = fromString $ "http://localhost/?color=" <> map toLower (show color)+ makeRequest dir url
src/Config.hs view
@@ -8,20 +8,20 @@ #ifdef TEST , ConfigFile(..) , readConfigFilesFrom+, tryReadFile #endif ) where import Imports -import GHC.Generics import Data.ByteString qualified as ByteString import System.Directory import System.Process-import Text.Casing import Data.Aeson import Data.Yaml import Util+import Config.DeepSeek configFilename :: FilePath configFilename = "sensei.yaml"@@ -39,7 +39,8 @@ -- | Shell command to run after the trigger cycle successfully completed. Has access to the result -- via seito. , onSuccess :: Maybe String-} deriving (Generic, Show, Eq)+, deepSeek :: Maybe DeepSeek+} deriving (Eq, Show, Generic) instance Semigroup ConfigFile where a <> b = ConfigFile {@@ -47,18 +48,16 @@ , afterReload = a.afterReload <|> b.afterReload , onFailure = a.onFailure <|> b.onFailure , onSuccess = a.onSuccess <|> b.onSuccess+ , deepSeek = a.deepSeek <|> b.deepSeek } instance Monoid ConfigFile where- mempty = ConfigFile Nothing Nothing Nothing Nothing+ mempty = ConfigFile Nothing Nothing Nothing Nothing Nothing instance FromJSON ConfigFile where parseJSON = \ case Null -> return mempty- value -> genericParseJSON defaultOptions {- fieldLabelModifier = kebab- , rejectUnknownFields = True- } value+ value -> genericKebabDecode value type Hook = IO HookResult @@ -69,6 +68,7 @@ , senseiHooksAfterReload :: Hook , senseiHooksOnSuccess :: Hook , senseiHooksOnFailure :: Hook+, deepSeek :: Maybe DeepSeek } tryReadFile :: FilePath -> IO (Maybe ByteString)@@ -96,6 +96,7 @@ , senseiHooksAfterReload = maybeToHook "after-reload" afterReload , senseiHooksOnSuccess = maybeToHook "on-success" onSuccess , senseiHooksOnFailure = maybeToHook "on-failure" onFailure+, deepSeek } where maybeToHook :: String -> Maybe String -> Hook maybeToHook name = maybe (return HookSuccess) (toHook name)
+ src/Config/DeepSeek.hs view
@@ -0,0 +1,16 @@+module Config.DeepSeek where++import Imports++data DeepSeek = DeepSeek {+ auth :: BearerToken+} deriving (Eq, Show, Generic)++newtype BearerToken = BearerToken { bearer :: ByteString }+ deriving (Eq, Show)++instance FromJSON DeepSeek where+ parseJSON = genericKebabDecode++instance FromJSON BearerToken where+ parseJSON = fmap (BearerToken . encodeUtf8) . parseJSON
+ src/DeepSeek.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+module DeepSeek (+ apply+#ifdef TEST+, Patch(..)+, extractPatch+#endif+) where++import Imports hiding (putStrLn, strip)++import Data.Ord+import System.Process+import System.Environment.Blank+import Data.ByteString.Lazy (toStrict)+import Data.Aeson+import qualified Data.Yaml.Pretty as Yaml+import Data.Text (Text)+import Network.HTTP.Types+import Network.HTTP.Client+import Network.HTTP.Simple++import GHC.Diagnostic (Diagnostic)+import qualified GHC.Diagnostic.Type as Diagnostic+import qualified Config.DeepSeek as Config+import DeepSeek.Types++separatorLength :: Int+separatorLength = 40++separator :: String+separator = take separatorLength $ repeat '#'++section :: String -> String+section name = take separatorLength $ take 3 separator ++ ' ' : name ++ ' ' : separator++apply :: (String -> IO ()) -> Config.DeepSeek -> FilePath -> Diagnostic -> IO ()+apply putStrLn config dir diagnostic = createChatCompletion dir diagnostic >>= \ case+ Nothing -> pass+ Just request -> (.choices) <$> query putStrLn config request >>= \ case+ [] -> pass+ choice : _ -> applyChoice choice+ where+ applyChoice :: Choice -> IO ()+ applyChoice choice = do+ case extractPatch diagnostic choice.message.content of+ Nothing -> putStrLn $ section "no patch"+ Just patch -> applyPatch putStrLn dir patch+ putStrLn separator++applyPatch :: (String -> IO ()) -> String -> Patch -> IO ()+applyPatch putStrLn dir patch = do+ env <- (:) ("POSIXLY_CORRECT", "true") <$> getEnvironment+ (status, out, err) <- readCreateProcessWithExitCode (proc "patch" ["-p" <> show patch.strip]) {+ cwd = guard (not $ null dir) $> dir+ , env = Just env+ } patch.diff+ when (status /= ExitSuccess) $ do+ putStrLn $ section "patch"+ unless (null out) $ putStrLn out+ unless (null err) $ putStrLn err++query :: (String -> IO ()) -> Config.DeepSeek -> CreateChatCompletion -> IO ChatCompletion+query putStrLn config (RequestBodyLBS . encode -> requestBody) = do+ body <- responseBody <$> httpLBS "https://api.deepseek.com/chat/completions" {+ method = "POST"+ , requestHeaders = [+ (hAccept, "application/json")+ , (hContentType, "application/json")+ , (hAuthorization, "Bearer " <> config.auth.bearer)+ ]+ , requestBody+ }+ logYamlBody body+ throwDecode body+ where+ logYamlBody :: LazyByteString -> IO ()+ logYamlBody body = do+ putStrLn $ section "response"+ putStrLn . decodeUtf8 $ toPrettyYaml body++ toPrettyYaml :: LazyByteString -> ByteString+ toPrettyYaml input = case decode @Value input of+ Nothing -> toStrict input+ Just value -> Yaml.encodePretty conf value+ where+ conf :: Yaml.Config+ conf = Yaml.setConfCompare (comparing fieldOrder) Yaml.defConfig++ fieldOrder :: Text -> Int+ fieldOrder name = fromMaybe maxBound . lookup name $ flip zip [1..] [+ "id"+ , "choices"+ , "created"+ , "model"+ , "system_fingerprint"+ , "object"+ , "usage"++ , "finish_reason"+ , "index"+ , "message"+ , "logprobs"++ , "content"+ , "role"++ , "completion_tokens"+ , "prompt_tokens"+ , "prompt_cache_hit_tokens"+ , "prompt_cache_miss_tokens"+ , "total_tokens"+ , "prompt_tokens_details"+ , "completion_tokens_details"+ ]++createChatCompletion :: FilePath -> Diagnostic -> IO (Maybe CreateChatCompletion)+createChatCompletion dir diagnostic = sequence $ diagnostic.span <&> \ span -> do+ source <- readFile (dir </> span.file)+ let+ content :: String+ content = unlines [+ "Given the following GHC diagnostics message, please suggest a fix for the corresponding Haskell code."+ , "Produce your fix as a unified diff so that it can be applied with the `patch` program."+ , "Don't provide explanations."+ , ""+ , "Enclose you answer in:"+ , ""+ , "```diff"+ , "--- " <> span.file+ , "+++ " <> span.file+ , "..."+ , "```"+ , ""+ , "(where ... is the placeholder for your answer)"+ , ""+ , "GHC diagnostics message:"+ , ""+ , "```console"+ , Diagnostic.format diagnostic+ , "```"+ , ""+ , "Corresponding Haskell code:"+ , ""+ , "```haskell"+ , source+ , "```"+ ]+ return CreateChatCompletion {+ messages = [ Message { role = User , content } ]+ , model = "deepseek-chat"+ , temperature = Just 0+ }++data Patch = Patch {+ strip :: Int+, diff :: String+} deriving (Eq, Show)++extractPatch :: Diagnostic -> String -> Maybe Patch+extractPatch diagnostic input = do+ diff <- extractDiffCodeBlock input+ span <- diagnostic.span+ file <- takeWhile (not . isSpace) . dropWhile isSpace <$> stripPrefix "--- " diff+ let strip = (length $ splitDirectories file) - (length $ splitDirectories span.file)+ Just Patch { strip, diff }++extractDiffCodeBlock :: String -> Maybe String+extractDiffCodeBlock = lines >>> \ case+ "```diff" : code -> case reverse code of+ "```" : (reverse >>> unlines -> diff) -> Just diff+ _ -> Nothing+ _ -> Nothing
+ src/DeepSeek/Types.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveAnyClass #-}+module DeepSeek.Types (+-- * Request+ CreateChatCompletion(..)+, Message(..)+, Role(..)++-- * Response+, ChatCompletion(..)+, Choice(..)+, FinishReason(..)+) where++import Imports++import Data.Aeson+import Data.Time.Clock.POSIX++data CreateChatCompletion = CreateChatCompletion {+ messages :: [Message]+, model :: String+, temperature :: Maybe Double+} deriving (Eq, Show, Generic, FromJSON, ToJSON)++data Message = Message {+ content :: String+, role :: Role+} deriving (Eq, Show, Generic, FromJSON, ToJSON)++data Role =+ System+ | User+ | Assistant+ deriving (Eq, Show)++instance ToJSON Role where+ toJSON = \ case+ System -> "system"+ User -> "user"+ Assistant -> "assistant"++instance FromJSON Role where+ parseJSON = withText "Role" \ case+ "system" -> return System+ "user" -> return User+ "assistant" -> return Assistant+ value -> fail ("invalid value " <> show value)++data ChatCompletion = ChatCompletion {+ id :: String+, choices :: [Choice]+, created :: POSIXTime+} deriving (Eq, Show, Generic, FromJSON, ToJSON)++data Choice = Choice {+ finish_reason :: FinishReason+, index :: Int+, message :: Message+} deriving (Eq, Show, Generic, FromJSON, ToJSON)++data FinishReason =+ Stop+ | Length+ | ContentFilter+ | ToolCalls+ | InsufficientSystemResource+ deriving (Eq, Show)++instance ToJSON FinishReason where+ toJSON = \ case+ Stop -> "stop"+ Length -> "length"+ ContentFilter -> "content_filter"+ ToolCalls -> "tool_calls"+ InsufficientSystemResource -> "insufficient_system_resource"++instance FromJSON FinishReason where+ parseJSON = withText "FinishReason" \ case+ "stop" -> return Stop+ "length" -> return Length+ "content_filter" -> return ContentFilter+ "tool_calls" -> return ToolCalls+ "insufficient_system_resource" -> return InsufficientSystemResource+ value -> fail ("invalid value " <> show value)
+ src/GHC/Diagnostic.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+module GHC.Diagnostic (+ module Diagnostic+, Action(..)+, analyze+, apply+#ifdef TEST+, extractIdentifiers+, applyReplace+#endif+) where++import Imports++import System.IO+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Builder (hPutBuilder)++import GHC.Diagnostic.Type as Diagnostic++data Action = Choices [Action] | AddExtension FilePath Text | Replace Span Text+ deriving (Eq, Show)++analyze :: Diagnostic -> Maybe Action+analyze diagnostic = analyzeCode <|> analyzeHints+ where+ analyzeCode :: Maybe Action+ analyzeCode = redundantImport+ where+ redundantImport :: Maybe Action+ redundantImport = matchCode 66111 >> removeLines++ matchCode :: Int -> Maybe ()+ matchCode expected = guard $ diagnostic.code == Just expected++ removeLines :: Maybe Action+ removeLines = Replace <$> diagnosticLines <*> pure ""++ diagnosticLines :: Maybe Span+ diagnosticLines = do+ span <- diagnostic.span+ return span {+ start = Location span.start.line 1+ , end = Location (span.end.line + 1) 1+ }++ analyzeHints :: Maybe Action+ analyzeHints = head $ mapMaybe analyzeHint diagnostic.hints++ analyzeHint :: String -> Maybe Action+ analyzeHint (T.pack -> hint) =+ perhapsYouIntendedToUse+ <|> enableAnyOfTheFollowingExtensions+ <|> perhapsUse+ <|> perhapsUseOneOfThese+ where+ perhapsYouIntendedToUse :: Maybe Action+ perhapsYouIntendedToUse = do+ AddExtension . (.file) <$> diagnostic.span <*> T.stripPrefix "Perhaps you intended to use " hint++ enableAnyOfTheFollowingExtensions :: Maybe Action+ enableAnyOfTheFollowingExtensions = do+ file <- (.file) <$> diagnostic.span+ T.stripPrefix "Enable any of the following extensions: " hint+ >>= head . reverse . map (AddExtension file) . T.splitOn ", "++ perhapsUse :: Maybe Action+ perhapsUse = Replace <$> diagnostic.span <*> (takeIdentifier <$> T.stripPrefix "Perhaps use `" hint)+ where+ takeIdentifier :: Text -> Text+ takeIdentifier = T.takeWhile (/= '\'')++ perhapsUseOneOfThese :: Maybe Action+ perhapsUseOneOfThese = do+ replaces <- Replace <$> diagnostic.span+ Choices . map replaces . extractIdentifiers <$> T.stripPrefix "Perhaps use one of these:" hint++extractIdentifiers :: Text -> [Text]+extractIdentifiers input = case T.breakOn "`" >>> snd >>> T.breakOn "\'" $ input of+ (T.drop 1 -> identifier, rest)+ | T.null rest -> []+ | otherwise -> identifier : extractIdentifiers rest++apply :: FilePath -> Maybe Int -> Action -> IO ()+apply dir c = relativeTo dir >>> go c+ where+ go :: Maybe Int -> Action -> IO ()+ go choice = \ case+ Choices choices -> do+ traverse_ (go Nothing) (head $ drop (maybe 0 pred choice) choices)+ AddExtension file name -> do+ old <- B.readFile file+ withFile file WriteMode $ \ h -> do+ hPutBuilder h $ "{-# LANGUAGE " <> T.encodeUtf8Builder name <> " #-}\n"+ B.hPutStr h old+ Replace span substitute -> do+ input <- B.readFile span.file <&> B.lines+ B.writeFile span.file . B.unlines $+ applyReplace span.start span.end substitute input++relativeTo :: FilePath -> Action -> Action+relativeTo dir = \ case+ Choices choices -> Choices $ map (relativeTo dir) choices+ AddExtension file name -> AddExtension (dir </> file) name+ Replace span substitute -> Replace span { file = dir </> span.file } substitute++applyReplace :: Location -> Location -> Text -> [ByteString] -> [ByteString]+applyReplace start end substitute input =+ let+ (before, rest) = splitAt (start.line - 1) input++ after :: [ByteString]+ after = drop (end.line - start.line + 1) rest++ decodedLines :: [Text]+ decodedLines = map T.decodeUtf8Lenient rest+ in case do+ firstLine <- head $ decodedLines+ lastLine <- head $ drop (end.line - start.line) decodedLines+ return $ T.take (start.column - 1) firstLine <> substitute <> T.drop (end.column - 1) lastLine+ of+ Nothing -> input+ Just substituted -> before ++ T.encodeUtf8 substituted : after
+ src/GHC/Diagnostic/Type.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NoImplicitPrelude #-}+module GHC.Diagnostic.Type (+ Diagnostic(..)+, Span(..)+, Location(..)+, Severity(..)+, parse+, format+) where++import Imports hiding ((<>), unlines, empty, unlines)++import Data.Aeson (decode)+import Data.ByteString.Lazy (fromStrict)+import Text.PrettyPrint++data Diagnostic = Diagnostic {+ version :: String+, ghcVersion :: String+, span :: Maybe Span+, severity :: Severity+, code :: Maybe Int+, message :: [String]+, hints :: [String]+} deriving (Eq, Show, Generic, ToJSON, FromJSON)++data Span = Span {+ file :: FilePath+, start :: Location+, end :: Location+} deriving (Eq, Show, Generic, ToJSON, FromJSON)++data Location = Location {+ line :: Int+, column :: Int+} deriving (Eq, Show, Generic, ToJSON, FromJSON)++data Severity = Warning | Error+ deriving (Eq, Show, Generic, ToJSON, FromJSON)++parse :: ByteString -> Maybe Diagnostic+parse = fmap removeGhciSpecificHints . decode . fromStrict++format :: Diagnostic -> String+format diagnostic = render $ unlines [+ hang header 4 messageWithHints+ , ""+ , ""+ ]+ where+ header :: Doc+ header = span <> colon <+> severity <> colon <+> code++ span :: Doc+ span = case diagnostic.span of+ Nothing -> "<no location info>"+ Just loc -> text loc.file <> colon <> int loc.start.line <> colon <> int loc.start.column++ severity :: Doc+ severity = case diagnostic.severity of+ Warning -> "warning"+ Error -> "error"++ code :: Doc+ code = case diagnostic.code of+ Nothing -> empty+ Just c -> brackets $ "GHC-" <> int c++ message :: Doc+ message = bulleted $ map verbatim diagnostic.message++ hints :: [Doc]+ hints = map verbatim diagnostic.hints++ messageWithHints :: Doc+ messageWithHints = case hints of+ [] -> message+ [h] -> message $$ hang (text "Suggested fix:") 2 h+ hs -> message $$ hang (text "Suggested fixes:") 2 (bulleted hs)++ bulleted :: [Doc] -> Doc+ bulleted = \ case+ [] -> empty+ [doc] -> doc+ docs -> vcat $ map (char '•' <+>) docs++ verbatim :: String -> Doc+ verbatim = unlines . map text . lines++ unlines :: [Doc] -> Doc+ unlines = foldr ($+$) empty++removeGhciSpecificHints :: Diagnostic -> Diagnostic+removeGhciSpecificHints diagnostic = diagnostic { hints = map processHint diagnostic.hints }+ where+ isSetLanguageExtension :: String -> Bool+ isSetLanguageExtension = isPrefixOf " :set -X"++ processHint :: String -> String+ processHint input = case lines input of+ [hint, "You may enable this language extension in GHCi with:", ghciHint]+ | isSetLanguageExtension ghciHint -> hint+ hint : "You may enable these language extensions in GHCi with:" : ghciHints+ | all isSetLanguageExtension ghciHints -> hint+ _ -> input
src/HTTP.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-} module HTTP ( withServer , socketName@@ -10,31 +11,36 @@ #endif ) where -import Imports+import Imports hiding (putStrLn, strip, encodeUtf8) import System.Directory-import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Aeson+import Data.ByteString.Builder import Network.Wai import Network.HTTP.Types+import qualified Network.HTTP.Types.Status as Status+import Network.HTTP.Media import Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings) import Network.Socket +import Util import qualified Trigger+import Config (Config)+import qualified Config+import qualified DeepSeek+import GHC.Diagnostic -socketName :: FilePath -> String-socketName dir = dir </> ".sensei.sock"+import HTTP.Util+import Sensei.API (QuickFixRequest(..)) socketAddr :: FilePath -> SockAddr socketAddr = SockAddrUnix . socketName -newSocket :: IO Socket-newSocket = socket AF_UNIX Stream 0- withSocket :: (Socket -> IO a) -> IO a withSocket = bracket newSocket close -withServer :: FilePath -> IO (Trigger.Result, String) -> IO a -> IO a-withServer dir trigger = withApplication dir (app trigger)+withServer :: (String -> IO ()) -> Config -> FilePath -> IO (Trigger.Result, String, [Diagnostic]) -> IO a -> IO a+withServer putStrLn config dir = withApplication dir . app putStrLn config dir withApplication :: FilePath -> Application -> IO a -> IO a withApplication dir application action = do@@ -57,12 +63,104 @@ takeMVar mvar return r -app :: IO (Trigger.Result, String) -> Application-app trigger _ respond = trigger >>= textPlain+app :: (String -> IO ()) -> Config -> FilePath -> IO (Trigger.Result, String, [Diagnostic]) -> Application+app putStrLn config dir getLastResult request respond = case pathInfo request of++ [] -> requireMethod "GET" $ do+ getLastResult >>= textPlain++ ["diagnostics"] -> requireMethod "GET" $ do+ (_, _, diagnostics) <- getLastResult+ respond $ json diagnostics++ ["quick-fix"] -> requireMethod "POST" $ do+ consumeRequestBodyLazy request <&> eitherDecode @QuickFixRequest >>= \ case+ Right quickFixRequest -> getLastResult >>= \ case+ (_, _, (analyze -> Just action) : _) -> do+ apply dir quickFixRequest.choice action+ noContent+ _ -> do+ noContent+ Left err -> badRequest err++ ["deep-fix"] -> requireMethod "POST" $ getLastResult >>= \ case+ (_, _, diagnostic : _) -> case config.deepSeek of+ Just conf -> do+ DeepSeek.apply putStrLn conf dir diagnostic+ noContent+ Nothing -> do+ serviceUnavailable "missing config value deep-seek.auth"+ _ -> do+ noContent+ _ -> do+ respond $ genericStatus Status.notFound404 request+ where- textPlain (result, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs)- where- status = case result of- Trigger.HookFailed -> internalServerError500- Trigger.Failure -> internalServerError500- Trigger.Success -> ok200+ noContent :: IO ResponseReceived+ noContent = respond $ jsonResponse Status.noContent204 ""++ serviceUnavailable :: String -> IO ResponseReceived+ serviceUnavailable = respond . genericRfc7807Response Status.serviceUnavailable503 . Just++ badRequest :: String -> IO ResponseReceived+ badRequest = respond . genericRfc7807Response Status.badRequest400 . Just++ color :: Either Builder Bool+ color = case join $ lookup "color" $ queryString request of+ Nothing -> Right True+ Just "false" -> Right False+ Just "true" -> Right True+ Just value -> Left $ "invalid value for color: " <> urlEncodeBuilder True value++ textPlain :: (Trigger.Result, FilePath, [Diagnostic]) -> IO ResponseReceived+ textPlain (result, xs, _diagnostics) = case color of+ Left err -> respond $ textResponse Status.badRequest400 err+ Right c -> respond . textResponse status . stringUtf8 $ strip xs+ where+ strip :: String -> String+ strip+ | c = id+ | otherwise = stripAnsi++ status :: Status+ status = case result of+ Trigger.HookFailed -> Status.internalServerError500+ Trigger.Failure -> Status.internalServerError500+ Trigger.Success -> Status.ok200++ requireMethod :: Method -> IO ResponseReceived -> IO ResponseReceived+ requireMethod required action = case requestMethod request of+ method | method == required -> action+ _ -> respond $ genericRfc7807Response Status.methodNotAllowed405 Nothing++ json :: ToJSON a => a -> Response+ json = jsonResponse Status.ok200 . fromEncoding . toEncoding++genericStatus :: Status -> Request -> Response+genericStatus status@(Status number message) request = fromMaybe text $ mapAcceptMedia [+ ("text/plain", text)+ , ("application/json", json)+ ] =<< lookup "Accept" request.requestHeaders+ where+ text :: Response+ text = textResponse status $ intDec number <> " " <> byteString message++ json :: Response+ json = genericRfc7807Response status Nothing++genericRfc7807Response :: Status -> Maybe String -> Response+genericRfc7807Response status@(Status number message) detail = jsonResponse status body+ where+ body :: Builder+ body = "{\n \"title\": \"" <> byteString message <> "\",\n \"status\": " <> intDec number <> renderedDetail <> "\n}"++ renderedDetail :: Builder+ renderedDetail = case detail of+ Nothing -> ""+ Just err -> ",\n \"detail\": " <> lazyByteString (encode err)++jsonResponse :: Status -> Builder -> Response+jsonResponse status body = responseBuilder status [(hContentType, "application/json")] body++textResponse :: Status -> Builder -> Response+textResponse status = responseBuilder status [(hContentType, "text/plain")]
+ src/HTTP/Util.hs view
@@ -0,0 +1,41 @@+module HTTP.Util where++import Imports++import Network.Socket+import Network.HTTP.Types+import Network.HTTP.Client+import Network.HTTP.Client.Internal (Connection, Response(..))+import qualified Data.ByteString.Lazy as L++socketName :: FilePath -> String+socketName dir = dir </> ".sensei.sock"++newSocket :: IO Socket+newSocket = socket AF_UNIX Stream 0++makeRequest :: FilePath -> Request -> IO (Bool, LazyByteString)+makeRequest dir url = handleSocketFileDoesNotExist name $ do+ manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection}+ Response{..} <- httpLbs url manager+ return (statusIsSuccessful responseStatus, responseBody)+ where+ name :: FilePath+ name = socketName dir++ newConnection :: Maybe HostAddress -> String -> Int -> IO Connection+ newConnection _ _ _ = do+ sock <- newSocket+ connect sock (SockAddrUnix name)+ socketConnection sock 8192++handleSocketFileDoesNotExist :: FilePath -> IO (Bool, LazyByteString) -> IO (Bool, LazyByteString)+handleSocketFileDoesNotExist name = fmap (either id id) . tryJust doesNotExist+ where+ doesNotExist :: HttpException -> Maybe (Bool, LazyByteString)+ doesNotExist = \ case+ HttpExceptionRequest _ (ConnectionFailure e) | isDoesNotExistException e -> Just (False, "could not connect to " <> L.fromStrict (encodeUtf8 name) <> "\n")+ _ -> Nothing++ isDoesNotExistException :: SomeException -> Bool+ isDoesNotExistException = maybe False isDoesNotExistError . fromException
src/Imports.hs view
@@ -1,31 +1,64 @@ {-# LANGUAGE CPP #-}-module Imports (module Imports) where+module Imports (+ module Imports+, Generic+, ToJSON(..)+, FromJSON(..)+) where +import Prelude as Imports hiding (span, head) import Control.Arrow as Imports ((>>>), (&&&)) import Control.Concurrent as Imports import Control.Exception as Imports hiding (handle) import Control.Monad as Imports import Data.Function as Imports (fix) import Control.Applicative as Imports-import Data.Functor as Imports ((<&>))+import Data.Functor as Imports ((<&>), ($>))+import Data.Foldable as Imports+import Data.Traversable as Imports import Data.Bifunctor as Imports import Data.Char as Imports import Data.Either as Imports-import Data.List as Imports+import Data.List as Imports hiding (span, head) import Data.Maybe as Imports import Data.String as Imports import Data.ByteString.Char8 as Imports (ByteString, pack, unpack)+import Data.ByteString.Lazy as Imports (LazyByteString) import Data.Tuple as Imports-import System.FilePath as Imports hiding (combine)+import System.FilePath as Imports hiding (addExtension, combine) import System.IO.Error as Imports (isDoesNotExistError) import Text.Read as Imports (readMaybe) import System.Exit as Imports (ExitCode(..))-import System.Process as Process import Control.Monad.IO.Class as Imports+import Data.Version as Imports (Version(..), showVersion, makeVersion) +import System.Process as Process import System.IO (Handle) import GHC.IO.Handle.Internals (wantReadableHandle_)+import GHC.Generics +import qualified Data.Version as Version+import Text.ParserCombinators.ReadP++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Text.Casing+import Data.Aeson+import Data.Aeson.Types (Parser)++genericKebabDecode :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a+genericKebabDecode = genericParseJSON kebabAesonOptions++genericKebabEncode :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value+genericKebabEncode = genericToJSON kebabAesonOptions++kebabAesonOptions :: Options+kebabAesonOptions = defaultOptions {+ fieldLabelModifier = kebab+, rejectUnknownFields = True+}+ pass :: Applicative m => m () pass = pure () @@ -46,3 +79,20 @@ #error Use `associateHandle'` as per https://hackage.haskell.org/package/process-1.6.17.0/docs/System-Process.html#v:createPipe #endif createPipe = Process.createPipe++encodeUtf8 :: String -> ByteString+encodeUtf8 = T.encodeUtf8 . T.pack++decodeUtf8 :: ByteString -> String+decodeUtf8 = T.unpack . T.decodeUtf8Lenient++strip :: String -> String+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++parseVersion :: String -> Maybe Version+parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of+ [v] -> Just v+ _ -> Nothing++head :: [a] -> Maybe a+head = listToMaybe
src/Language/Haskell/GhciWrapper.hs view
@@ -4,27 +4,58 @@ , Interpreter(echo) , withInterpreter , eval++, Extract(..)+, partialMessageStartsWithOneOf , evalVerbose++, ReloadStatus(..)+, reload++#ifdef TEST+, sensei_ghc_version+, lookupGhc+, lookupGhcVersion+, numericVersion+, extractReloadDiagnostics+, extractDiagnostics+#endif ) where import Imports import qualified Data.ByteString as ByteString-import Data.Text.Encoding (decodeUtf8)-import qualified Data.Text as T import System.IO hiding (stdin, stdout, stderr)-import System.Directory (doesFileExist, makeAbsolute)+import System.IO.Temp (withSystemTempFile) import System.Environment (getEnvironment) import System.Process hiding (createPipe) import System.Exit (exitFailure) import Util (isWritableByOthers)+import ReadHandle hiding (getResult) import qualified ReadHandle-import ReadHandle (ReadHandle, toReadHandle)+import GHC.Diagnostic (Diagnostic)+import qualified GHC.Diagnostic as Diagnostic +sensei_ghc_version :: String+sensei_ghc_version = "SENSEI_GHC_VERSION"++lookupGhc :: [(String, String)] -> FilePath+lookupGhc = fromMaybe "ghc" . lookup "SENSEI_GHC"++lookupGhcVersion :: [(String, String)] -> Maybe String+lookupGhcVersion = lookup sensei_ghc_version++getGhcVersion :: FilePath -> [(String, String)] -> IO String+getGhcVersion ghc env = case lookupGhcVersion env of+ Nothing -> numericVersion ghc+ Just version -> return version++numericVersion :: [Char] -> IO [Char]+numericVersion ghc = strip <$> readProcess ghc ["--numeric-version"] ""+ data Config = Config { configIgnoreDotGhci :: Bool-, configStartupFile :: FilePath , configWorkingDirectory :: Maybe FilePath , configEcho :: ByteString -> IO () }@@ -40,31 +71,62 @@ die :: String -> IO a die = throwIO . ErrorCall -withInterpreter :: Config -> [String] -> (Interpreter -> IO r) -> IO r-withInterpreter config args = bracket (new config args) close+withInterpreter :: Config -> [(String, String)] -> [String] -> (Interpreter -> IO r) -> IO r+withInterpreter config envDefaults args action = do+ withSystemTempFile "sensei" $ \ startupFile h -> do+ hPutStrLn h $ unlines [+ ":set prompt \"\""+ , ":unset +m +r +s +t +c"+ , ":seti -XHaskell2010"+ , ":seti -XNoOverloadedStrings" + -- GHCi uses NoBuffering for stdout and stderr by default:+ -- https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/ghci.html+ , "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"+ , "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"++ , "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8"+ , "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8"+ ]+ hClose h+ bracket (new startupFile config envDefaults args) close action+ sanitizeEnv :: [(String, String)] -> [(String, String)] sanitizeEnv = filter p where p ("HSPEC_FAILURES", _) = False p _ = True -new :: Config -> [String] -> IO Interpreter-new Config{..} args_ = do+new :: FilePath -> Config -> [(String, String)] -> [String] -> IO Interpreter+new startupFile Config{..} envDefaults args_ = do checkDotGhci- requireFile configStartupFile- startupFile <- makeAbsolute configStartupFile env <- sanitizeEnv <$> getEnvironment+ let- args = "-ghci-script" : startupFile : args_ ++ catMaybes [+ ghc :: String+ ghc = lookupGhc env++ ghcVersion <- parseVersion <$> getGhcVersion ghc env++ let+ diagnosticsAsJson :: [String] -> [String]+ diagnosticsAsJson+ | ghcVersion < Just (makeVersion [9,10]) = id+ | otherwise = ("-fdiagnostics-as-json" :)++ mandatoryArgs :: [String]+ mandatoryArgs = ["-fshow-loaded-modules", "--interactive"]++ args :: [String]+ args = "-ghci-script" : startupFile : diagnosticsAsJson args_ ++ catMaybes [ if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing- ]+ ] ++ mandatoryArgs (stdoutReadEnd, stdoutWriteEnd) <- createPipe - (Just stdin_, Nothing, Nothing, processHandle ) <- createProcess (proc "ghci" args) {+ (Just stdin_, Nothing, Nothing, processHandle ) <- createProcess (proc ghc args) { cwd = configWorkingDirectory- , env = Just env+ , env = Just $ envDefaults ++ env , std_in = CreatePipe , std_out = UseHandle stdoutWriteEnd , std_err = UseHandle stdoutWriteEnd@@ -86,17 +148,9 @@ _ <- printStartupMessages interpreter getProcessExitCode processHandle >>= \ case Just _ -> exitFailure- Nothing -> do- -- GHCi uses NoBuffering for stdout and stderr by default:- -- https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/ghci.html- evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"- evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"-- evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8"- evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8"-- return interpreter+ Nothing -> return interpreter where+ checkDotGhci :: IO () checkDotGhci = unless configIgnoreDotGhci $ do let dotGhci = fromMaybe "" configWorkingDirectory </> ".ghci" isWritableByOthers dotGhci >>= \ case@@ -108,30 +162,19 @@ , "" ] - requireFile name = do- exists <- doesFileExist name- unless exists $ do- die $ "Required file " <> show name <> " does not exist!"-+ setMode :: Handle -> IO () setMode h = do hSetBinaryMode h False hSetBuffering h LineBuffering hSetEncoding h utf8 - printStartupMessages :: Interpreter -> IO String- printStartupMessages interpreter = evalVerbose interpreter ""-- evalThrow :: Interpreter -> String -> IO ()- evalThrow interpreter expr = do- output <- eval interpreter expr- unless (null output) $ do- close interpreter- die output+ printStartupMessages :: Interpreter -> IO (String, [Either ReloadStatus Diagnostic])+ printStartupMessages interpreter = evalVerbose extractReloadDiagnostics interpreter "" close :: Interpreter -> IO () close Interpreter{..} = do hClose hIn- ReadHandle.drain readHandle echo+ ReadHandle.drain extractReloadDiagnostics readHandle echo hClose hOut e <- waitForProcess process when (e /= ExitSuccess) $ do@@ -143,14 +186,42 @@ ByteString.hPut stdin ReadHandle.marker hFlush stdin -getResult :: Interpreter -> IO String-getResult Interpreter{..} = T.unpack . decodeUtf8 <$> ReadHandle.getResult readHandle echo+extractReloadDiagnostics :: Extract (Either ReloadStatus Diagnostic)+extractReloadDiagnostics = extractReloadStatus <+> extractDiagnostics +data ReloadStatus = Ok | Failed+ deriving (Eq, Show)++extractReloadStatus :: Extract ReloadStatus+extractReloadStatus = Extract {+ isPartialMessage = partialMessageStartsWithOneOf [ok, failed]+, parseMessage = \ case+ line | ByteString.isPrefixOf ok line -> Just (Ok, "")+ line | ByteString.isPrefixOf failed line -> Just (Failed, "")+ _ -> Nothing+} where+ ok = "Ok, modules loaded: "+ failed = "Failed, modules loaded: "++extractDiagnostics :: ReadHandle.Extract Diagnostic+extractDiagnostics = ReadHandle.Extract {+ isPartialMessage = ByteString.isPrefixOf "{"+, parseMessage = fmap (id &&& encodeUtf8 . Diagnostic.format) . Diagnostic.parse+}++getResult :: Extract a -> Interpreter -> IO (String, [a])+getResult extract Interpreter{..} = first decodeUtf8 <$> ReadHandle.getResult extract readHandle echo+ silent :: ByteString -> IO () silent _ = pass eval :: Interpreter -> String -> IO String-eval ghci = evalVerbose ghci {echo = silent}+eval ghci = fmap fst . evalVerbose extractDiagnostics ghci {echo = silent} -evalVerbose :: Interpreter -> String -> IO String-evalVerbose ghci expr = putExpression ghci expr >> getResult ghci+evalVerbose :: Extract a -> Interpreter -> String -> IO (String, [a])+evalVerbose extract ghci expr = putExpression ghci expr >> getResult extract ghci++reload :: Interpreter -> IO (String, (ReloadStatus, [Diagnostic]))+reload ghci = evalVerbose extractReloadDiagnostics ghci ":reload" <&> second \ case+ (partitionEithers -> ([Ok], diagnostics)) -> (Ok, diagnostics)+ (partitionEithers ->(_, diagnostics)) -> (Failed, diagnostics)
src/ReadHandle.hs view
@@ -3,9 +3,14 @@ ReadHandle(..) , toReadHandle , marker+, Extract(..)+, (<+>)+, partialMessageStartsWith+, partialMessageStartsWithOneOf , getResult , drain #ifdef TEST+, breakAfterNewLine , newEmptyBuffer #endif ) where@@ -34,9 +39,9 @@ , buffer :: IORef Buffer } -drain :: ReadHandle -> (ByteString -> IO ()) -> IO ()-drain h echo = while (not <$> isEOF h) $ do- _ <- getResult h echo+drain :: Extract a -> ReadHandle -> (ByteString -> IO ()) -> IO ()+drain extract h echo = while (not <$> isEOF h) $ do+ _ <- getResult extract h echo pass isEOF :: ReadHandle -> IO Bool@@ -73,14 +78,69 @@ newEmptyBuffer :: IO (IORef Buffer) newEmptyBuffer = newIORef BufferEmpty -getResult :: ReadHandle -> (ByteString -> IO ()) -> IO ByteString-getResult h echo = mconcat <$> go- where- go :: IO [ByteString]- go = nextChunk h >>= \ case- Chunk chunk -> echo chunk >> (chunk :) <$> go+data Extract a = Extract {+ isPartialMessage :: ByteString -> Bool+, parseMessage :: ByteString -> Maybe (a, ByteString)+} deriving Functor++(<+>) :: Extract a -> Extract b -> Extract (Either a b)+(<+>) a b = Extract {+ isPartialMessage = \ input -> a.isPartialMessage input || b.isPartialMessage input+, parseMessage = \ input -> first Left <$> a.parseMessage input <|> first Right <$> b.parseMessage input+}++partialMessageStartsWith :: ByteString -> ByteString -> Bool+partialMessageStartsWith prefix chunk = ByteString.isPrefixOf chunk prefix || ByteString.isPrefixOf prefix chunk++partialMessageStartsWithOneOf :: [ByteString] -> ByteString -> Bool+partialMessageStartsWithOneOf xs x = any ($ x) $ map partialMessageStartsWith xs++getResult :: Extract a -> ReadHandle -> (ByteString -> IO ()) -> IO (ByteString, [a])+getResult extract h echo = fmap reverse <$> do+ ref <- newIORef []++ let+ startOfLine :: ByteString -> IO [ByteString]+ startOfLine = \ case+ "" -> withMoreInput_ startOfLine+ chunk | extract.isPartialMessage chunk -> extractMessage chunk+ chunk -> notStartOfLine chunk++ notStartOfLine :: ByteString -> IO [ByteString]+ notStartOfLine chunk = case breakAfterNewLine chunk of+ Nothing -> echo chunk >> (chunk :) <$> withMoreInput_ notStartOfLine+ Just (x, xs) -> echo x >> (x :) <$> startOfLine xs++ extractMessage :: ByteString -> IO [ByteString]+ extractMessage chunk = case breakAfterNewLine chunk of+ Nothing -> withMoreInput chunk startOfLine+ Just (x, xs) -> do+ c <- case extract.parseMessage x of+ Nothing -> do+ return x+ Just (message, formatted) -> do+ modifyIORef' ref (message :)+ return formatted+ echo c >> (c :) <$> startOfLine xs++ withMoreInput_ :: (ByteString -> IO [ByteString]) -> IO [ByteString]+ withMoreInput_ action = nextChunk h >>= \ case+ Chunk chunk -> action chunk Marker -> return [] EOF -> return []++ withMoreInput :: ByteString -> (ByteString -> IO [ByteString]) -> IO [ByteString]+ withMoreInput acc action = nextChunk h >>= \ case+ Chunk chunk -> action (acc <> chunk)+ Marker -> echo acc >> return [acc]+ EOF -> echo acc >> return [acc]++ (,) <$> (mconcat <$> withMoreInput_ startOfLine) <*> readIORef ref++breakAfterNewLine :: ByteString -> Maybe (ByteString, ByteString)+breakAfterNewLine input = case ByteString.elemIndex '\n' input of+ Just n -> Just (ByteString.splitAt (n + 1) input)+ Nothing -> Nothing data Chunk = Chunk ByteString | Marker | EOF
src/Run.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-} module Run ( run , runWeb@@ -10,11 +11,12 @@ #endif ) where -import Imports+import qualified Prelude+import Imports hiding (putStrLn) import qualified Data.ByteString as ByteString import Data.IORef-import System.IO+import System.IO hiding (putStrLn) import qualified System.FSNotify as FSNotify import qualified HTTP@@ -26,6 +28,7 @@ import Pager (pager) import Util import Config+import GHC.Diagnostic waitForever :: IO () waitForever = forever $ threadDelay 10000000@@ -57,14 +60,22 @@ data Mode = Lenient | Strict -run :: FilePath -> [String] -> IO ()-run startupFile args = do- runArgs@RunArgs{dir, lastOutput, queue} <- defaultRunArgs startupFile- HTTP.withServer dir (readMVar lastOutput) $ do+run :: [String] -> IO ()+run args = do+ config <- loadConfig+ runArgs@RunArgs{dir, lastOutput, queue, cleanupAction} <- defaultRunArgs++ let+ putStrLn :: String -> IO ()+ putStrLn message = do+ cleanupAction.add $ Prelude.putStrLn message+ cleanupAction.run++ HTTP.withServer putStrLn config dir (readMVar lastOutput) $ do watchFiles dir queue $ do mode <- newIORef Lenient Input.watch stdin (dispatch mode queue) (emitEvent queue Done)- runWith runArgs {args}+ runWith runArgs {config, args} where dispatch :: IORef Mode -> EventQueue -> Char -> IO () dispatch mode queue = \ case@@ -82,53 +93,62 @@ Lenient -> Strict Strict -> Lenient -defaultRunArgs :: FilePath -> IO RunArgs-defaultRunArgs startupFile = do+defaultRunArgs :: IO RunArgs+defaultRunArgs = do queue <- newQueue- lastOutput <- newMVar (Trigger.Success, "")+ lastOutput <- newMVar (Trigger.Success, "", [])+ cleanupAction <- newCleanupAction return RunArgs {- ignoreConfig = False+ config = defaultConfig , dir = "" , args = []- , lastOutput = lastOutput+ , lastOutput , queue = queue- , sessionConfig = defaultSessionConfig startupFile+ , sessionConfig = defaultSessionConfig , withSession = Session.withSession+ , cleanupAction } data RunArgs = RunArgs {- ignoreConfig :: Bool+ config :: Config , dir :: FilePath , args :: [String]-, lastOutput :: MVar (Result, String)+, lastOutput :: MVar (Result, String, [Diagnostic]) , queue :: EventQueue , sessionConfig :: Session.Config , withSession :: forall r. Session.Config -> [String] -> (Session.Session -> IO r) -> IO r+, cleanupAction :: CleanupAction } +data CleanupAction = CleanupAction {+ run :: IO ()+, add :: IO () -> IO ()+}++newCleanupAction :: IO CleanupAction+newCleanupAction = do+ mvar <- newMVar pass+ return CleanupAction {+ run = modifyMVar_ mvar \ action -> do+ action+ return pass+ , add = \ new -> modifyMVar_ mvar \ existing -> do+ return $ existing >> new+ }+ runWith :: RunArgs -> IO () runWith RunArgs {..} = do- config <- case ignoreConfig of- False -> loadConfig- True -> return defaultConfig- cleanup <- newIORef pass let- runCleanupAction :: IO ()- runCleanupAction = join $ atomicModifyIORef' cleanup $ (,) pass-- addCleanupAction :: IO () -> IO ()- addCleanupAction cleanupAction = atomicModifyIORef' cleanup $ \ action -> (action >> cleanupAction, ())-- saveOutput :: IO (Trigger.Result, String) -> IO ()+ saveOutput :: IO (Trigger.Result, String, [Diagnostic]) -> IO () saveOutput action = do- runCleanupAction+ cleanupAction.run result <- modifyMVar lastOutput $ \ _ -> (id &&& id) <$> action case result of- (HookFailed, _output) -> pass- (Failure, output) -> config.senseiHooksOnFailure >>= \ case- HookSuccess -> pager output >>= addCleanupAction+ (HookFailed, _output, _diagnostics) -> pass+ (Failure, output, _diagnostics) -> config.senseiHooksOnFailure >>= \ case+ HookSuccess -> pager output >>= cleanupAction.add HookFailure message -> hPutStrLn stderr message- (Success, _output) -> config.senseiHooksOnSuccess >>= \ case+ (Success, _output, _diagnostics) -> config.senseiHooksOnSuccess >>= \ case HookSuccess -> pass HookFailure message -> hPutStrLn stderr message @@ -138,30 +158,36 @@ , afterReload = config.senseiHooksAfterReload } + go :: [String] -> IO () go extraArgs = do status <- withSession sessionConfig (extraArgs <> args) $ \ session -> do let- triggerAction = saveOutput (trigger session hooks)- triggerAllAction = saveOutput (triggerAll session hooks)+ printExtraArgs :: IO ()+ printExtraArgs = forM_ extraArgs $ \ arg -> do+ sessionConfig.configEcho . encodeUtf8 . withColor Red $ arg <> "\n"++ triggerAction = saveOutput (trigger session hooks <* printExtraArgs)+ triggerAllAction = saveOutput (triggerAll session hooks <* printExtraArgs)+ triggerAction- processQueue runCleanupAction (sessionConfig.configEcho . encodeUtf8) dir queue triggerAllAction triggerAction+ processQueue cleanupAction.run (sessionConfig.configEcho . encodeUtf8) dir queue triggerAllAction triggerAction case status of Restart mExtraArgs -> go (fromMaybe extraArgs mExtraArgs) Terminate -> return () go [] -runWeb :: FilePath -> [String] -> IO ()-runWeb startupFile args = do- Session.withSession (defaultSessionConfig startupFile) args $ \session -> do+runWeb :: [String] -> IO ()+runWeb args = do+ config <- loadConfig+ Session.withSession defaultSessionConfig args $ \ session -> do _ <- trigger session defaultHooks lock <- newMVar ()- HTTP.withServer "" (withMVar lock $ \() -> trigger session defaultHooks) $ do+ HTTP.withServer Prelude.putStrLn config "" (withMVar lock $ \() -> trigger session defaultHooks) $ do waitForever -defaultSessionConfig :: FilePath -> Session.Config-defaultSessionConfig startupFile = Session.Config {+defaultSessionConfig :: Session.Config+defaultSessionConfig = Session.Config { configIgnoreDotGhci = False-, configStartupFile = startupFile , configWorkingDirectory = Nothing , configEcho = \ string -> ByteString.putStr string >> hFlush stdout }
+ src/Sensei/API.hs view
@@ -0,0 +1,34 @@+module Sensei.API (+ QuickFixRequest(..)+, quickFix+, deepFix+) where++import Imports++import Network.HTTP.Client+import Data.Aeson qualified as Aeson++import HTTP.Util (makeRequest)++data QuickFixRequest = QuickFixRequest {+ choice :: Maybe Int+} deriving (Eq, Show, Generic)++instance ToJSON QuickFixRequest where+ toJSON = genericKebabEncode++instance FromJSON QuickFixRequest where+ parseJSON = genericKebabDecode++quickFix :: FilePath -> QuickFixRequest -> IO (Bool, LazyByteString)+quickFix dir (RequestBodyLBS . Aeson.encode -> requestBody) = makeRequest dir request+ where+ request :: Request+ request = "http://localhost/quick-fix" { method = "POST", requestBody }++deepFix :: FilePath -> IO (Bool, LazyByteString)+deepFix dir = makeRequest dir request+ where+ request :: Request+ request = "http://localhost/deep-fix" { method = "POST" }
src/Session.hs view
@@ -4,6 +4,8 @@ , Session(..) , echo , withSession++, ReloadStatus(..) , reload , Summary(..)@@ -18,18 +20,23 @@ , hasSpec , hasHspecCommandSignature , hspecCommand-, parseSummary+, Extract(..)+, extractSummary+, ansiShowCursor #endif ) where import Imports import Data.IORef+import qualified Data.ByteString as ByteString -import Language.Haskell.GhciWrapper+import Language.Haskell.GhciWrapper hiding (reload)+import qualified Language.Haskell.GhciWrapper as Interpreter import Util import Options+import GHC.Diagnostic data Session = Session { interpreter :: Interpreter@@ -46,16 +53,19 @@ hspecPreviousSummary :: MonadIO m => Session -> m (Maybe Summary) hspecPreviousSummary session = liftIO $ readIORef session.hspecPreviousSummaryRef +envDefaults :: [(String, String)]+envDefaults = [("HSPEC_EXPERT", "yes")]+ withSession :: Config -> [String] -> (Session -> IO r) -> IO r withSession config args action = do- withInterpreter config ghciArgs $ \ ghci -> do+ withInterpreter config envDefaults ("-Werror" : ghciArgs) $ \ ghci -> do ref <- newIORef (Just $ Summary 0 0) action (Session ghci hspecArgs ref) where (ghciArgs, hspecArgs) = splitArgs args -reload :: MonadIO m => Session -> m String-reload session = liftIO $ evalVerbose session.interpreter ":reload"+reload :: MonadIO m => Session -> m (String, (ReloadStatus, [Diagnostic]))+reload session = liftIO $ Interpreter.reload session.interpreter data Summary = Summary { summaryExamples :: Int@@ -100,8 +110,8 @@ runSpec command session = do failedPreviously <- isFailure <$> hspecPreviousSummary session let args = "--color" : (if failedPreviously then addRerun else id) session.hspecArgs- r <- evalVerbose session.interpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command- writeIORef session.hspecPreviousSummaryRef (parseSummary r)+ (r, summary) <- evalVerbose extractSummary session.interpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command+ writeIORef session.hspecPreviousSummaryRef . listToMaybe $ reverse summary return r where addRerun :: [String] -> [String]@@ -113,13 +123,24 @@ isSuccess :: Maybe Summary -> Bool isSuccess = not . isFailure -parseSummary :: String -> Maybe Summary-parseSummary = findJust . map (readMaybe . dropAnsiEscapeSequences) . reverse . lines- where- findJust = listToMaybe . catMaybes+extractSummary :: Extract Summary+extractSummary = Extract {+ isPartialMessage = partialMessageStartsWithOneOf [summaryPrefix, ansiShowCursor <> summaryPrefix]+, parseMessage+} where+ summaryPrefix :: ByteString+ summaryPrefix = "Summary {" - dropAnsiEscapeSequences xs- | "Summary" `isPrefixOf` xs = xs- | otherwise = case xs of- _ : ys -> dropAnsiEscapeSequences ys- [] -> []+ parseMessage :: ByteString -> Maybe (Summary, ByteString)+ parseMessage input = case ByteString.stripPrefix ansiShowCursor input of+ Nothing -> flip (,) "" <$> parseSummary input+ Just i -> flip (,) ansiShowCursor <$> parseSummary i++ parseSummary :: ByteString -> Maybe Summary+ parseSummary = readMaybe . decodeUtf8 . stripAnsiShowCursor++ stripAnsiShowCursor :: ByteString -> ByteString+ stripAnsiShowCursor input = fromMaybe input $ ByteString.stripPrefix ansiShowCursor input++ansiShowCursor :: ByteString+ansiShowCursor = "\ESC[?25h"
src/Trigger.hs view
@@ -8,7 +8,6 @@ , trigger , triggerAll #ifdef TEST-, reloadedSuccessfully , removeProgress #endif ) where@@ -26,8 +25,9 @@ import Util import Config (Hook, HookResult(..))-import Session (Session, isFailure, isSuccess, hspecPreviousSummary, resetSummary)+import Session (Session, ReloadStatus(..), isFailure, isSuccess, hspecPreviousSummary, resetSummary) import qualified Session+import GHC.Diagnostic data Hooks = Hooks { beforeReload :: Hook@@ -43,22 +43,11 @@ data Result = HookFailed | Failure | Success deriving (Eq, Show) -triggerAll :: Session -> Hooks -> IO (Result, String)+triggerAll :: Session -> Hooks -> IO (Result, String, [Diagnostic]) triggerAll session hooks = do resetSummary session trigger session hooks -reloadedSuccessfully :: String -> Bool-reloadedSuccessfully = any success . lines- where- success :: String -> Bool- success x = case stripPrefix "Ok, " x of- Just "one module loaded." -> True- Just "1 module loaded." -> True- Just xs | [_number, "modules", "loaded."] <- words xs -> True- Just xs -> "modules loaded: " `isPrefixOf` xs- Nothing -> False- removeProgress :: String -> String removeProgress xs = case break (== '\r') xs of (_, "") -> xs@@ -67,23 +56,23 @@ dropLastLine :: String -> String dropLastLine = reverse . dropWhile (/= '\n') . reverse -type Trigger = ExceptT Result (WriterT String IO)+type Trigger = ExceptT Result (WriterT (String, [Diagnostic]) IO) -trigger :: Session -> Hooks -> IO (Result, String)+trigger :: Session -> Hooks -> IO (Result, String, [Diagnostic]) trigger session hooks = runWriterT (runExceptT go) >>= \ case- (Left result, output) -> return (result, output)- (Right (), output) -> return (Success, output)+ (Left result, (output, diagnostics)) -> return (result, output, diagnostics)+ (Right (), (output, diagnostics)) -> return (Success, output, diagnostics) where go :: Trigger () go = do runHook hooks.beforeReload- output <- Session.reload session- tell output- case reloadedSuccessfully output of- False -> do+ (output, (r, diagnostics)) <- Session.reload session+ tell (output, diagnostics)+ case r of+ Failed -> do echo $ withColor Red "RELOADING FAILED" <> "\n" abort- True -> do+ Ok -> do echo $ withColor Green "RELOADING SUCCEEDED" <> "\n" runHook hooks.afterReload@@ -105,7 +94,8 @@ runSpec :: IO String -> Trigger () runSpec hspec = do- liftIO hspec >>= tell . removeProgress+ r <- removeProgress <$> liftIO hspec+ tell (r, []) result <- hspecPreviousSummary session unless (isSuccess result) abort @@ -116,5 +106,5 @@ echo :: String -> Trigger () echo message = do- tell message+ tell (message, []) liftIO $ Session.echo session message
src/Util.hs view
@@ -3,7 +3,7 @@ Color(..) , withColor , withInfoColor-, encodeUtf8+, stripAnsi , isBoring , filterGitIgnoredFiles , normalizeTypeSignatures@@ -23,7 +23,6 @@ import System.Posix.Files import System.Posix.Types import qualified Data.Text as T-import qualified Data.Text.Encoding as T withInfoColor :: String -> String withInfoColor = withColor Magenta@@ -34,9 +33,26 @@ set = setSGRCode [SetColor Foreground Dull c] reset = setSGRCode [] -encodeUtf8 :: String -> ByteString-encodeUtf8 = T.encodeUtf8 . T.pack+-- |+-- Remove terminal sequences.+stripAnsi :: String -> String+stripAnsi = go+ where+ go input = case input of+ '\ESC' : '[' : (dropNumericParameters -> c : xs) | isCommand c -> go xs+ '\ESC' : '[' : '?' : (dropNumericParameters -> c : xs) | isCommand c -> go xs+ x : xs -> x : go xs+ [] -> [] + dropNumericParameters :: FilePath -> FilePath+ dropNumericParameters = dropWhile (`elem` ("0123456789;" :: [Char]))++ isCommand :: Char -> Bool+ isCommand = (`elem` commands)++ commands :: FilePath+ commands = ['A'..'Z'] <> ['a'..'z']+ isBoring :: FilePath -> Bool isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p where@@ -76,11 +92,13 @@ normalizeTypeSignatures :: String -> String normalizeTypeSignatures = normalize . concatMap replace where+ normalize :: [Char] -> [Char] normalize = \case- '\n' : ' ' : ' ' : xs -> normalizeTypeSignatures (' ' : dropWhile (== ' ') xs)- x : xs -> x : normalizeTypeSignatures xs+ '\n' : ' ' : ' ' : xs -> normalize (' ' : dropWhile (== ' ') xs)+ x : xs -> x : normalize xs [] -> [] + replace :: Char -> [Char] replace c = case c of '\8759' -> "::" '\8594' -> "->"
− startup.ghci
@@ -1,4 +0,0 @@-:set prompt ""-:unset +m +r +s +t +c-:seti -XHaskell2010-:seti -XNoOverloadedStrings
test/ClientSpec.hs view
@@ -2,24 +2,40 @@ import Helper -import HTTP+import Config+import HTTP (socketName)+import qualified HTTP import Client import qualified Trigger +withSuccess :: (FilePath -> IO a) -> IO a+withSuccess = withServer Trigger.Success (withColor Green "success")++withFailure :: (FilePath -> IO a) -> IO a+withFailure = withServer Trigger.Failure (withColor Red "failure")++withServer :: Trigger.Result -> String -> (FilePath -> IO a) -> IO a+withServer result text action = do+ withTempDirectory $ \ dir -> do+ HTTP.withServer (\ _ -> pass) defaultConfig dir (return (result, text, [])) $ do+ action dir+ spec :: Spec spec = do describe "client" $ do- it "does a HTTP request via a Unix domain socket" $ do- withTempDirectory $ \ dir -> do- withServer dir (return (Trigger.Success, "hello")) $ do- client dir `shouldReturn` (True, "hello")+ it "accepts --color" $ do+ withSuccess $ \ dir -> do+ client dir ["--color"] `shouldReturn` (True, fromString $ withColor Green "success") + it "accepts --no-color" $ do+ withSuccess $ \ dir -> do+ client dir ["--no-color"] `shouldReturn` (True, "success")+ it "indicates failure" $ do- withTempDirectory $ \ dir -> do- withServer dir (return (Trigger.Failure, "hello")) $ do- client dir `shouldReturn` (False, "hello")+ withFailure $ \ dir -> do+ client dir ["--color"] `shouldReturn` (False, fromString $ withColor Red "failure") context "when server socket is missing" $ do it "reports error" $ do withTempDirectory $ \ dir -> do- client dir `shouldReturn` (False, "could not connect to " <> fromString (socketName dir) <> "\n")+ client dir [] `shouldReturn` (False, "could not connect to " <> fromString (socketName dir) <> "\n")
test/ConfigSpec.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-+{-# OPTIONS_GHC -Wno-ambiguous-fields #-} module ConfigSpec (spec) where import Helper@@ -9,6 +9,7 @@ import Data.ByteString.Lazy qualified as LB import Config+import Config.DeepSeek spec :: Spec spec = do@@ -84,6 +85,7 @@ , beforeReload = Just "blah" , onSuccess = Just "snafu" , onFailure = Just "failure"+ , deepSeek = Nothing } it "supports null" $ do@@ -97,6 +99,7 @@ , beforeReload = Just "blah" , onSuccess = Just "finally" , onFailure = Just "failure"+ , deepSeek = Nothing } it "supports missing fields" $ do@@ -107,8 +110,17 @@ , beforeReload = Nothing , onSuccess = Nothing , onFailure = Nothing+ , deepSeek = Nothing } - it "accepts an emty config" $ do+ it "accepts deep-seek configuration values" $ do+ fromJSON [yamlQQ|+ deep-seek:+ auth: foo+ |] `shouldBe` Success @ConfigFile mempty {+ deepSeek = Just $ DeepSeek $ BearerToken "foo"+ }++ it "accepts an empty config" $ do fromJSON @ConfigFile [yamlQQ| |] `shouldBe` Success mempty
+ test/DeepSeekSpec.hs view
@@ -0,0 +1,51 @@+module DeepSeekSpec (spec) where++import Helper++import DeepSeek++spec :: Spec+spec = do+ describe "extractPatch" $ do+ it "extracts patch" $ do+ let+ err :: Diagnostic+ err = (diagnostic Error) {+ span = Just Span {+ file = "src/DeepSeek/Types.hs"+ , start = Location 0 0+ , end = Location 0 0+ }+ }+ input :: String+ input = unlines [+ "```diff"+ , "--- a/src/DeepSeek/Types.hs"+ , "+++ b/src/DeepSeek/Types.hs"+ , "@@ -11,7 +11,7 @@"+ , " import GHC.Generics (Generic)"+ , " import Data.Aeson (FromJSON, ToJSON)"+ , " import Data.Text (Text)"+ , "-import Data.Time.Clock.POSIX (POSIXTime)"+ , "+import Data.Time.Clock.POSIX ()"+ , ""+ , " data Request = Request {"+ , " model :: String"+ , "```"+ ]+ extractPatch err input `shouldBe` Just Patch {+ strip = 1+ , diff = unlines [+ "--- a/src/DeepSeek/Types.hs"+ , "+++ b/src/DeepSeek/Types.hs"+ , "@@ -11,7 +11,7 @@"+ , " import GHC.Generics (Generic)"+ , " import Data.Aeson (FromJSON, ToJSON)"+ , " import Data.Text (Text)"+ , "-import Data.Time.Clock.POSIX (POSIXTime)"+ , "+import Data.Time.Clock.POSIX ()"+ , ""+ , " data Request = Request {"+ , " model :: String"+ ]+ }
test/EventQueueSpec.hs view
@@ -9,7 +9,7 @@ withGitRepository :: (FilePath -> IO a) -> IO a withGitRepository action = withTempDirectory $ \ dir -> do- readProcess "git" ["-C", dir, "init"] "" >> action dir+ readProcess "git" ["-C", dir, "init", "--initial-branch=main"] "" >> action dir spec :: Spec spec = do
+ test/GHC/DiagnosticSpec.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE CPP #-}+module GHC.DiagnosticSpec (spec) where++import Prelude hiding (span)++import Helper hiding (diagnostic)++import System.Process+import System.Environment+import Data.Text (Text)++import Language.Haskell.GhciWrapper (lookupGhc)+import GHC.Diagnostic++data Requirement = NoRequirement | RequireGhc912++test :: HasCallStack => FilePath -> [String] -> Maybe Action -> Spec+test name args = testWith name NoRequirement args++testWith :: HasCallStack => FilePath -> Requirement -> [String] -> Maybe Action -> Spec+testWith name requirement extraArgs action = it name $ do+ err <- translate <$> ghc ["-fno-diagnostics-show-caret"]+ json <- encodeUtf8 <$> ghc ["-fdiagnostics-as-json", "--interactive", "-ignore-dot-ghci"]+ ensureFile (dir </> "err.out") (encodeUtf8 err)+ ensureFile (dir </> "err.json") json+ Just diagnostic <- return $ parse json+ when shouldRun $ do+ format diagnostic `shouldBe` err+ normalizeFileName <$> analyze diagnostic `shouldBe` action+ where+ dir :: FilePath+ dir = "test" </> "assets" </> name++ ghc :: [String] -> IO String+ ghc args = do+ requireGhc [9,10]+ bin <- lookupGhc <$> getEnvironment+ let+ process :: CreateProcess+ process = proc bin ("-fno-code" : args ++ extraArgs ++ [dir </> "Foo.hs"])+ (_, _, err) <- readCreateProcessWithExitCode process ""+ return err++ translate :: String -> String+ translate = map \ case+ '‘' -> '`'+ '’' -> '\''+ c -> c++ shouldRun :: Bool+ shouldRun = case requirement of+ NoRequirement -> True+ RequireGhc912 ->+#if __GLASGOW_HASKELL__ < 912+ False+#else+ True+#endif++normalizeFileName :: Action -> Action+normalizeFileName = \ case+ Choices choices -> Choices $ map normalizeFileName choices+ AddExtension _ name -> AddExtension "Foo.hs" name+ Replace span substitute -> Replace span {file = "Foo.hs"} substitute++ftest :: HasCallStack => FilePath -> [String] -> Maybe Action -> Spec+ftest name args = focus . test name args++xtest :: HasCallStack => FilePath -> [String] -> Maybe Action -> Spec+xtest name args = before_ pending . test name args++_ignore :: ()+_ignore = let _ = (ftest, xtest) in ()++replace :: Location -> Location -> Text -> Action+replace start end = Replace (Span "Foo.hs" start end)++replace_ :: Location -> Location -> Text -> Maybe Action+replace_ start end = Just . replace start end++addExtension :: Text -> Maybe Action+addExtension = Just . AddExtension "Foo.hs"++spec :: Spec+spec = do+ describe "format" $ do+ test "not-in-scope" [] Nothing+ test "not-in-scope-perhaps-use" [] $ replace_ (Location 2 7) (Location 2 14) "filter"+ test "not-in-scope-perhaps-use-one-of-these" [] . Just . Choices $ map+ (replace (Location 2 7) (Location 2 11)) [+ "foldl"+ , "foldr"+ ]+ test "not-in-scope-perhaps-use-multiline" [] . Just . Choices $ map+ (replace (Location 3 7) (Location 3 11)) [+ "foldl"+ , "foldr"+ ]+ test "use-BlockArguments" [] $ addExtension "BlockArguments"+ test "use-TemplateHaskellQuotes" [] $ addExtension "TemplateHaskellQuotes"+ testWith "redundant-import" RequireGhc912 ["-Wall", "-Werror"] $ replace_ (Location 2 1) (Location 3 1) ""+ test "non-existing" [] Nothing+ test "parse-error" [] Nothing+ test "lex-error" [] Nothing+ test "multiple-error-messages" [] Nothing++ describe "extractIdentifiers" $ do+ it "extracts identifiers" $ do+ extractIdentifiers ".. `foldl' ..., `foldr' .." `shouldBe` ["foldl", "foldr"]++ describe "applyReplace" $ do+ it "replaces a given source span with a substitute" $ do+ applyReplace (Location 2 7) (Location 2 14) "filter" [+ "module Foo where"+ , "foo = filter_ p xs"+ ] `shouldBe` [+ "module Foo where"+ , "foo = filter p xs"+ ]++ it "correctly handles source spans that span over multiple lines" $ do+ applyReplace (Location 2 8) (Location 3 7) "Ya" [+ "module Foo where"+ , "import Data.Maybe"+ , "foo = bar"+ , "one = two"+ ] `shouldBe` [+ "module Foo where"+ , "import Yabar"+ , "one = two"+ ]
test/HTTPSpec.hs view
@@ -1,19 +1,169 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-ambiguous-fields #-} module HTTPSpec (spec) where -import Helper+import Helper hiding (putStrLn, pending)+import qualified Prelude+import qualified VCR +import Network.Wai (Application) import Test.Hspec.Wai+import Test.Hspec.Wai.Internal (WaiSession(..))+import Control.Monad.Trans.State (StateT(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import qualified Data.ByteString as B -import HTTP+import Config+import Config.DeepSeek+import qualified HTTP import qualified Trigger+import qualified GHC.Diagnostic.Type as Diagnostic +verbose :: Bool+verbose = False++putStrLn :: String -> IO ()+putStrLn+ | verbose = Prelude.putStrLn+ | otherwise = \ _ -> pass++withTape :: VCR.Tape -> WaiSession st a -> WaiSession st a+withTape tape = lift (VCR.with tape)+ where+ lift :: forall st a. (forall b. IO b -> IO b) -> WaiSession st a -> WaiSession st a+ lift f action = WaiSession $ ReaderT \ st -> ReaderT \ application -> StateT \ clientState -> do+ f $ runStateT (runReaderT (runReaderT (unWaiSession action) st) application) clientState+ spec :: Spec spec = do describe "app" $ do- with (return $ app $ return (Trigger.Success, "hello")) $ do- it "returns 200 on success" $ do- get "/" `shouldRespondWith` 200+ let+ file :: FilePath+ file = "Foo.hs" - with (return $ app $ return (Trigger.Failure, "hello")) $ do- it "return 500 on failure" $ do- get "/" `shouldRespondWith` 500+ withApp :: (Trigger.Result, String, [Diagnostic]) -> SpecWith (FilePath, Application) -> Spec+ withApp lastResult = around \ item -> withTempDirectory \ dir -> do+ item (dir, HTTP.app putStrLn defaultConfig dir $ return lastResult)++ withAppWithFailure :: FilePath -> SpecWith (FilePath, Application) -> Spec+ withAppWithFailure name = around \ item -> withTempDirectory \ dir -> do+ let+ testCaseDir :: FilePath+ testCaseDir = "test/assets" </> name++ copySource :: IO ()+ copySource = readFile (testCaseDir </> file) >>= writeFile (dir </> file)++ readErrFile :: IO (Maybe Diagnostic)+ readErrFile = fmap normalizeFileName . Diagnostic.parse <$> B.readFile (testCaseDir </> "err.json")++ copySource+ Just err <- readErrFile+ config <- loadConfig++ let+ deepSeek :: Maybe DeepSeek+ deepSeek = config.deepSeek <|> Just (DeepSeek $ BearerToken "")++ app :: Application+ app = HTTP.app putStrLn defaultConfig { deepSeek } dir (return $ (Trigger.Failure, "", [err]))++ item (dir, app)+ where+ normalizeFileName :: Diagnostic -> Diagnostic+ normalizeFileName err = err { span = normalizeSpan <$> err.span }++ normalizeSpan :: Span -> Span+ normalizeSpan span = span { file }++ describe "/" $ do+ context "on success" $ do+ withApp (Trigger.Success, withColor Green "success", []) $ do+ it "returns status 200" $ do+ get "/" `shouldRespondWith` fromString (withColor Green "success")++ context "with ?color" $ do+ it "keeps terminal sequences" $ do+ get "/?color" `shouldRespondWith` fromString (withColor Green "success")++ context "with ?color=true" $ do+ it "keeps terminal sequences" $ do+ get "/?color=true" `shouldRespondWith` fromString (withColor Green "success")++ context "with ?color=false" $ do+ it "removes terminal sequences" $ do+ get "/?color=false" `shouldRespondWith` "success"++ context "with an invalid value for ?color" $ do+ it "returns status 400" $ do+ get "/?color=some%20value" `shouldRespondWith` 400 { matchBody = "invalid value for color: some%20value" }++ context "on failure" $ do+ withApp (Trigger.Failure, withColor Red "failure", []) $ do+ it "return 500" $ do+ get "/" `shouldRespondWith` 500++ describe "/diagnostics" $ do+ let+ start :: Location+ start = Location 23 42++ span :: Maybe Span+ span = Just $ Span "Foo.hs" start start++ err :: Diagnostic+ err = (diagnostic Error) { span, message = ["failure"] }++ expected :: ResponseMatcher+ expected = fromString . decodeUtf8 $ to_json [err]++ withApp (Trigger.Failure, "", [err]) $ do+ it "returns GHC diagnostics" $ do+ get "/diagnostics" `shouldRespondWith` expected++ describe "/quick-fix" $ do+ withAppWithFailure "use-TemplateHaskellQuotes" $ do+ it "applies quick fixes" $ do+ post "/quick-fix" "{}" `shouldRespondWith` "" { matchStatus = 204 }+ dir <- getState+ liftIO $ readFile (dir </> file) `shouldReturn` unlines [+ "{-# LANGUAGE TemplateHaskellQuotes #-}"+ , "module Foo where"+ , "foo = [|23|]"+ ]++ withAppWithFailure "not-in-scope-perhaps-use-one-of-these" $ do+ context "when \"choice\" is specified" $ do+ it "applies the selected solution" $ do+ post "/quick-fix" "{\"choice\":2}" `shouldRespondWith` "" { matchStatus = 204 }+ dir <- getState+ liftIO $ readFile (dir </> file) `shouldReturn` unlines [+ "module Foo where"+ , "foo = foldr"+ ]++ describe "/deep-fix" $ do+ withAppWithFailure "use-TemplateHaskellQuotes" $ do+ it "applies quick fixes using DeepSeek" >>> sequential $ withTape "test/vcr/tape.yaml" do+ post "/deep-fix" "" `shouldRespondWith` "" { matchStatus = 204 }+ dir <- getState+ liftIO $ readFile (dir </> file) `shouldReturn` unlines [+ "{-# LANGUAGE TemplateHaskell #-}"+ , "module Foo where"+ , "foo = [|23|]"+ ]++ context "when querying a non-existing endpoint" $ withApp undefined $ do+ it "returns status 404" $ do+ get "/foo" `shouldRespondWith` 404 {matchBody = "404 Not Found"}++ context "with \"Accept: application/json\"" $ do+ it "returns a JSON error" $ do+ request "GET" "/foo" [("Accept", "application/json")] "" `shouldRespondWith` 404 {+ matchBody = fromString $ intercalate "\n" [+ "{"+ , " \"title\": \"Not Found\","+ , " \"status\": 404"+ , "}"+ ]+ }
test/Helper.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Helper ( module Imports , silent@@ -7,15 +9,25 @@ , passingSpec , passingMetaSpec , failingSpec-, Status(..)-, modulesLoaded , Color(..) , withColor , timeout++, Diagnostic(..)+, Span(..)+, Location(..)+, Severity(..)+, diagnostic++, to_json++, requireGhc+, ensureFile ) where +import Prelude hiding (span) import Imports import System.Directory as Imports@@ -28,10 +40,17 @@ import System.Environment import qualified System.Timeout +import qualified Data.ByteString as ByteString+import Data.ByteString.Lazy (toStrict)+import Data.Aeson (encode)+ import Run ()+import Config (tryReadFile) import Util-import Language.Haskell.GhciWrapper (Config(..))+import Language.Haskell.GhciWrapper +import GHC.Diagnostic+ timeout :: IO a -> IO (Maybe a) timeout action = lookupEnv "CI" >>= \ case Nothing -> System.Timeout.timeout 5_000_000 action@@ -43,7 +62,6 @@ ghciConfig :: Config ghciConfig = Config { configIgnoreDotGhci = True-, configStartupFile = "startup.ghci" , configWorkingDirectory = Nothing , configEcho = silent }@@ -93,19 +111,28 @@ , " it \"bar\" False" ] -data Status = Ok | Failed- deriving (Eq, Show)+diagnostic :: Severity -> Diagnostic+diagnostic severity = Diagnostic {+ version = "1.0"+, ghcVersion = "ghc-9.10.1"+, span = Nothing+, severity+, code = Nothing+, message = []+, hints = []+} -modulesLoaded :: Status -> [String] -> String-modulesLoaded status xs = show status ++ ", " ++ mods ++ " loaded."- where- n = length xs- mods- | n == 0 = "no modules"- | n == 1 = "one module"- | n == 2 = "two modules"- | n == 3 = "three modules"- | n == 4 = "four modules"- | n == 5 = "five modules"- | n == 6 = "six modules"- | otherwise = show n ++ " modules"+to_json :: ToJSON a => a -> ByteString+to_json = toStrict . encode++requireGhc :: [Int] -> IO ()+requireGhc (makeVersion -> required) = do+ env <- getEnvironment+ let Just ghcVersion = lookupGhcVersion env >>= parseVersion+ when (ghcVersion < required) pending++ensureFile :: FilePath -> ByteString -> IO ()+ensureFile name new = do+ old <- tryReadFile name+ unless (old == Just new) $ do+ ByteString.writeFile name new
test/Language/Haskell/GhciWrapperSpec.hs view
@@ -2,27 +2,34 @@ module Language.Haskell.GhciWrapperSpec (main, spec) where import Helper+import Util import qualified Data.ByteString.Char8 as ByteString -import Language.Haskell.GhciWrapper (Config(..), Interpreter(..))+import Language.Haskell.GhciWrapper (Config(..), Interpreter(..), ReloadStatus(..), Extract(..)) import qualified Language.Haskell.GhciWrapper as Interpreter main :: IO () main = hspec spec withInterpreter :: [String] -> (Interpreter -> IO a) -> IO a-withInterpreter = Interpreter.withInterpreter ghciConfig+withInterpreter = Interpreter.withInterpreter ghciConfig [] withGhci :: ((String -> IO String) -> IO a) -> IO a withGhci action = withInterpreter [] $ action . Interpreter.eval +extractNothing :: Extract ()+extractNothing = Extract {+ isPartialMessage = const False+, parseMessage = undefined+}+ spec :: Spec spec = do describe "withInterpreter" $ do context "on shutdown" $ do it "drains `stdout` of the `ghci` process" $ do result <- withSpy $ \ spy -> do- Interpreter.withInterpreter ghciConfig {configEcho = spy} [] $ \ _ghci -> do+ Interpreter.withInterpreter ghciConfig {configEcho = spy} [] [] $ \ _ghci -> do pass last (ByteString.lines $ mconcat result) `shouldBe` "Leaving GHCi." @@ -33,7 +40,7 @@ let dotGhci = dir </> ".ghci" writeFile dotGhci "" callProcess "chmod" ["go+w", dotGhci]- Interpreter.withInterpreter config { configWorkingDirectory = Just dir } [] $ \ ghci -> Interpreter.eval ghci "23"+ Interpreter.withInterpreter config { configWorkingDirectory = Just dir } [] [] $ \ ghci -> Interpreter.eval ghci "23" context "when configIgnoreDotGhci is False" $ do it "terminates with an error message" $ do@@ -55,7 +62,7 @@ it "echos result" $ do fmap mconcat . withSpy $ \ spy -> do withInterpreter [] $ \ ghci -> do- Interpreter.evalVerbose ghci {echo = spy} "23" `shouldReturn` "23\n"+ Interpreter.evalVerbose extractNothing ghci {echo = spy} "23" `shouldReturn` ("23\n", []) `shouldReturn` "23\n" describe "eval" $ do@@ -116,9 +123,52 @@ ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n" it "gives an error message for identifiers that are not in scope" $ withGhci $ \ ghci -> do- ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo")+ ghci "foo" >>= (`shouldContain` "Variable not in scope: foo") context "with -XNoImplicitPrelude" $ do it "works" $ withInterpreter ["-XNoImplicitPrelude"] $ \ ghci -> do- Interpreter.eval ghci "putStrLn \"foo\"" >>= (`shouldContain` "Variable not in scope: putStrLn")+ normalizeTypeSignatures <$> Interpreter.eval ghci "putStrLn \"foo\"" >>= (`shouldContain` "Variable not in scope: putStrLn") Interpreter.eval ghci "23" `shouldReturn` "23\n"++ describe "reload" do+ let+ withModule :: (FilePath -> IO a) -> IO a+ withModule action = withTempDirectory \ dir -> do+ let+ file :: FilePath+ file = dir </> "Foo.hs"+ writeFile file "module Foo where"+ action file++ failingModule :: String -> IO ()+ failingModule file = writeFile file $ unlines [+ "module Foo where"+ , "foo = bar"+ ]++ it "indicates success" do+ withModule \ file -> do+ withInterpreter [file] \ ghci -> do+ Interpreter.reload ghci `shouldReturn` ("", (Ok, []))++ it "indicates failure" do+ withModule \ file -> do+ withInterpreter [file] \ ghci -> do+ failingModule file+ snd <$> Interpreter.reload ghci `shouldReturn` (Failed, [+#if __GLASGOW_HASKELL__ >= 910+ (diagnostic Error) {+ span = Just $ Span file (Location 2 7) (Location 2 10)+ , code = Just 88464+ , message = ["Variable not in scope: bar"]+ }+#endif+ ])++ context "with -fno-diagnostics-as-json" $ do+ it "does not extract diagnostics" do+ requireGhc [9,10]+ withModule \ file -> do+ withInterpreter ["-fno-diagnostics-as-json", file] \ ghci -> do+ failingModule file+ snd <$> Interpreter.reload ghci `shouldReturn` (Failed, [])
test/ReadHandleSpec.hs view
@@ -1,9 +1,14 @@ module ReadHandleSpec (spec) where +import Prelude hiding (span) import Helper+ import Test.QuickCheck import qualified Data.ByteString as ByteString +import Session (Summary(..), extractSummary)+import Language.Haskell.GhciWrapper (extractReloadDiagnostics, extractDiagnostics)+ import ReadHandle chunkByteString :: (Int, Int) -> ByteString -> Gen [ByteString]@@ -24,22 +29,29 @@ withRandomChunkSizes (mconcat -> input) action = property $ do chunkSizes <- elements [SmallChunks, BigChunks] let+ maxChunkSize :: Int maxChunkSize = case chunkSizes of SmallChunks -> 4 BigChunks -> ByteString.length input chunks <- chunkByteString (1, maxChunkSize) input- return $ fakeHandle chunks >>= action+ return $ do+ counterexample (unlines $ map show chunks) $ do+ fakeHandle chunks >>= action partialMarker :: ByteString partialMarker = ByteString.take 5 marker spec :: Spec spec = do+ describe "breakAfterNewLine" $ do+ it "brakes after newline" $ do+ breakAfterNewLine "foo\nbar\nbaz" `shouldBe` Just ("foo\n", "bar\nbaz")+ describe "drain" $ do it "drains all remaining input" $ do h <- fakeHandle ["foo", marker, "bar", marker, "baz", marker, ""]- withSpy (drain h) `shouldReturn` ["foo", "bar", "baz"]+ withSpy (drain extractReloadDiagnostics h) `shouldReturn` ["foo", "bar", "baz"] describe "getResult" $ do context "with a single result" $ do@@ -48,62 +60,153 @@ it "returns result" $ do withSpy $ \ echo -> do h <- fakeHandle input- getResult h echo `shouldReturn` "foobarbaz"+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foobarbaz", []) `shouldReturn` ["foo", "bar", "baz"] context "with chunks of arbitrary size" $ do it "returns result" $ do withRandomChunkSizes input $ \ h -> do fmap mconcat . withSpy $ \ echo -> do- getResult h echo `shouldReturn` "foobarbaz"+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foobarbaz", []) `shouldReturn` "foobarbaz" + context "with extractSummary" $ do+ let+ summary :: Summary+ summary = Summary 5 3++ it "extracts Summary" $ do+ let+ chunks :: [ByteString]+ chunks = [+ "foo\n"+ , "bar\n"+ , encodeUtf8 $ show summary <> "\n"+ , "baz\n"+ , marker+ ]++ withRandomChunkSizes chunks $ \ h -> do+ fmap mconcat . withSpy $ \ echo -> do+ getResult extractSummary h echo `shouldReturn` ("foo\nbar\nbaz\n", [summary])+ `shouldReturn` "foo\nbar\nbaz\n"++ context "when predicate does not match" $ do+ it "does not attempt parsing" $ do+ let+ extract :: Extract Summary+ extract = extractSummary {parseMessage = undefined}++ chunks :: [ByteString]+ chunks = [+ "foo\n"+ , "bar\n"+ , encodeUtf8 . take 8 $ show summary <> "\n"+ , "baz\n"+ , marker+ ]++ withRandomChunkSizes chunks $ \ h -> do+ fmap mconcat . withSpy $ \ echo -> do+ getResult extract h echo `shouldReturn` ("foo\nbar\nSummary baz\n", [])+ `shouldReturn` "foo\nbar\nSummary baz\n"++ context "with extractDiagnostics" $ do+ let+ extract :: Extract Diagnostic+ extract = extractDiagnostics {+ parseMessage = fmap (second $ const "") . extractDiagnostics.parseMessage+ }++ it "extracts Diagnostic" $ do+ let+ start :: Location+ start = Location 23 42++ span :: Maybe Span+ span = Just $ Span "Foo.hs" start start++ err1 :: Diagnostic+ err1 = (diagnostic Error) { span }++ err2 :: Diagnostic+ err2 = err1 { code = Just 23 }++ chunks :: [ByteString]+ chunks = [+ "foo\n"+ , "bar\n"+ , to_json err1 <> "\n"+ , "baz\n"+ , to_json err2 { code = Just 23 } <> "\n"+ , marker+ ]+ withRandomChunkSizes chunks $ \ h -> do+ fmap mconcat . withSpy $ \ echo -> do+ getResult extract h echo `shouldReturn` ("foo\nbar\nbaz\n", [err1, err2])+ `shouldReturn` "foo\nbar\nbaz\n"++ context "with a partial match" $ do+ it "retains the original input" $ do+ let+ chunks :: [ByteString]+ chunks = [+ "foo\n"+ , "bar\n"+ , "{..."+ , marker+ ]+ withRandomChunkSizes chunks $ \ h -> do+ fmap mconcat . withSpy $ \ echo -> do+ getResult extract h echo `shouldReturn` ("foo\nbar\n{...", [])+ `shouldReturn` "foo\nbar\n{..."+ context "with multiple results" $ do let input = ["foo", marker, "bar", marker, "baz", marker] it "returns one result at a time" $ do withSpy $ \ echo -> do h <- fakeHandle input- getResult h echo `shouldReturn` "foo"- getResult h echo `shouldReturn` "bar"- getResult h echo `shouldReturn` "baz"+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foo", [])+ getResult extractReloadDiagnostics h echo `shouldReturn` ("bar", [])+ getResult extractReloadDiagnostics h echo `shouldReturn` ("baz", []) `shouldReturn` ["foo", "bar", "baz"] context "with chunks of arbitrary size" $ do it "returns one result at a time" $ do withRandomChunkSizes input $ \ h -> do fmap mconcat . withSpy $ \ echo -> do- getResult h echo `shouldReturn` "foo"- getResult h echo `shouldReturn` "bar"- getResult h echo `shouldReturn` "baz"+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foo", [])+ getResult extractReloadDiagnostics h echo `shouldReturn` ("bar", [])+ getResult extractReloadDiagnostics h echo `shouldReturn` ("baz", []) `shouldReturn` "foobarbaz" context "when a chunk that contains a marker ends with a partial marker" $ do it "correctly gives the marker precedence over the partial marker" $ do withSpy $ \ echo -> do h <- fakeHandle ["foo" <> marker <> "bar" <> partialMarker, ""]- getResult h echo `shouldReturn` "foo"- getResult h echo `shouldReturn` ("bar" <> partialMarker)+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foo", [])+ getResult extractReloadDiagnostics h echo `shouldReturn` ("bar" <> partialMarker, []) `shouldReturn` ["foo", "bar", partialMarker] context "on EOF" $ do it "returns all remaining input" $ do withSpy $ \ echo -> do h <- fakeHandle ["foo", "bar", "baz", ""]- getResult h echo `shouldReturn` "foobarbaz"+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foobarbaz", []) `shouldReturn` ["foo", "bar", "baz"] context "with a partialMarker at the end" $ do it "includes the partial marker in the output" $ do withSpy $ \ echo -> do h <- fakeHandle ["foo", "bar", "baz", partialMarker, ""]- getResult h echo `shouldReturn` ("foobarbaz" <> partialMarker)+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foobarbaz" <> partialMarker, []) `shouldReturn` ["foo", "bar", "baz", partialMarker] context "after a marker" $ do it "returns all remaining input" $ do withSpy $ \ echo -> do h <- fakeHandle ["foo", "bar", "baz", marker, "qux", ""]- getResult h echo `shouldReturn` "foobarbaz"- getResult h echo `shouldReturn` "qux"+ getResult extractReloadDiagnostics h echo `shouldReturn` ("foobarbaz", [])+ getResult extractReloadDiagnostics h echo `shouldReturn` ("qux", []) `shouldReturn` ["foo", "bar", "baz", "qux"]
test/RunSpec.hs view
@@ -10,8 +10,8 @@ defaultRunArgs :: IO RunArgs defaultRunArgs = do- args <- Run.defaultRunArgs "startup.ghci"- return args { ignoreConfig = True, sessionConfig = args.sessionConfig { configEcho = silent } }+ args <- Run.defaultRunArgs+ return args { sessionConfig = args.sessionConfig { configEcho = silent } } spec :: Spec spec = do@@ -28,7 +28,7 @@ RunArgs{..} <- defaultRunArgs let runArgs = RunArgs {- withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do+ withSession = \ conf sessionArgs action -> withSession conf sessionArgs $ \ session -> do spy sessionArgs action session <* emitEvent runArgs.queue Done , ..@@ -43,7 +43,7 @@ RunArgs{..} <- defaultRunArgs let runArgs = RunArgs {- withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do+ withSession = \ conf sessionArgs action -> withSession conf sessionArgs $ \ session -> do spy sessionArgs action session <* emitEvent runArgs.queue Done , ..@@ -60,7 +60,7 @@ RunArgs{..} <- defaultRunArgs let runArgs = RunArgs {- withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do+ withSession = \ conf sessionArgs action -> withSession conf sessionArgs $ \ session -> do spy sessionArgs nextEvent >>= emitEvent runArgs.queue action session
test/SessionSpec.hs view
@@ -36,11 +36,6 @@ withSession ["-XOverloadedStrings", "-Wall", "-Werror"] $ \ Session{..} -> do eval interpreter "23 :: Int" `shouldReturn` "23\n" - describe "reload" $ do- it "reloads" $ do- withSession [] $ \session -> do- Session.reload session `shouldReturn` (modulesLoaded Ok [] ++ "\n")- describe "hasSpec" $ around withSomeSpec $ do context "when module contains spec" $ do it "returns True" $ \ name -> do@@ -89,24 +84,17 @@ _ <- runSpec session >> runSpec session hspecPreviousSummary session `shouldReturn` Just (Summary 1 0) - describe "parseSummary" $ do- let summary = Summary 2 0-- it "parses summary" $ do- Session.parseSummary (show summary) `shouldBe` Just summary+ describe "extractSummary" $ do+ let+ summary :: Summary+ summary = Summary 0 0 - it "ignores additional output before / after summary" $ do- (Session.parseSummary . unlines) [- "foo"- , show summary- , "bar"- ] `shouldBe` Just summary+ input :: ByteString+ input = fromString $ show summary - it "gives last occurrence precedence" $ do- (Session.parseSummary . unlines) [- show (Summary 3 0)- , show summary- ] `shouldBe` Just summary+ it "extracts summary" $ do+ extractSummary.parseMessage input `shouldBe` Just (summary, "") - it "ignores additional output at the beginning of a line (to cope with ansi escape sequences)" $ do- Session.parseSummary ("foo " ++ show summary) `shouldBe` Just (Summary 2 0)+ context "when the input starts with the ANSI \"show cursor\"-sequence" $ do+ it "extracts summary" $ do+ extractSummary.parseMessage (ansiShowCursor <> input) `shouldBe` Just (summary, ansiShowCursor)
test/SpecHook.hs view
@@ -1,7 +1,34 @@ module SpecHook where -import Test.Hspec+import Helper+import System.Environment import GHC.Conc +import qualified Language.Haskell.GhciWrapper as Interpreter++installPackageEnvironment :: FilePath -> FilePath -> IO ()+installPackageEnvironment ghc file = callProcess "cabal" ["install", "-v0", "-w", ghc, "-z", "--lib", "hspec", "hspec-meta", "--package-env", file]++ensurePackageEnvironment :: FilePath -> FilePath -> IO ()+ensurePackageEnvironment ghc file = doesFileExist file >>= \ case+ False -> installPackageEnvironment ghc file+ True -> pass++getGhcVersion :: FilePath -> IO String+getGhcVersion ghc = do+ ghcVersion <- Interpreter.numericVersion ghc+ setEnv Interpreter.sensei_ghc_version ghcVersion+ return ghcVersion++setPackageEnvironment :: IO ()+setPackageEnvironment = do+ dir <- getCurrentDirectory+ env <- getEnvironment+ let ghc = Interpreter.lookupGhc env+ ghcVersion <- getGhcVersion ghc+ let file = dir </> "dist-newstyle" </> "test-env" </> ghcVersion+ ensurePackageEnvironment ghc file+ setEnv "GHC_ENVIRONMENT" file+ hook :: Spec -> Spec-hook spec = runIO (getNumProcessors >>= setNumCapabilities) >> parallel spec+hook spec = runIO (setPackageEnvironment >> getNumProcessors >>= setNumCapabilities) >> parallel spec
test/TriggerSpec.hs view
@@ -39,22 +39,14 @@ trigger session = triggerWithHooks session defaultHooks triggerWithHooks :: Session -> Hooks -> IO (Result, [String])-triggerWithHooks session hooks = fmap normalize <$> Trigger.trigger session hooks+triggerWithHooks session hooks = do+ (result, output, _) <- Trigger.trigger session hooks+ return (result, normalize output) triggerAll :: Session -> IO (Result, [String])-triggerAll session = fmap normalize <$> Trigger.triggerAll session defaultHooks--requiresHspecMeta :: IO () -> IO ()-requiresHspecMeta action = try action >>= \ case- Left (ExitFailure 1) -> expectationFailure $ unlines [- "This tests requires `hspec-meta`, which is not available. To address this run"- , ""- , " echo | cabal repl sensei --build-depends hspec-meta"- , ""- , "once."- ]- Left err -> throwIO err- Right () -> pass+triggerAll session = do+ (result, output, _) <- Trigger.triggerAll session defaultHooks+ return (result, normalize output) data HookExecuted = BeforeReloadSucceeded | AfterReloadSucceeded deriving (Eq, Show)@@ -70,29 +62,6 @@ spec :: Spec spec = do- describe "reloadedSuccessfully" $ do- context "with GHC < 8.2.1" $ do- it "detects success" $ do- reloadedSuccessfully "Ok, modules loaded: Spec." `shouldBe` True-- context "with GHC >= 8.2.1" $ do- context "with a single module" $ do- it "detects success" $ do- reloadedSuccessfully "Ok, 1 module loaded." `shouldBe` True-- context "with multiple modules" $ do- it "detects success" $ do- reloadedSuccessfully "Ok, 5 modules loaded." `shouldBe` True-- context "with GHC >= 8.2.2" $ do- context "with a single module" $ do- it "detects success" $ do- reloadedSuccessfully "Ok, one module loaded." `shouldBe` True-- context "with multiple modules" $ do- it "detects success" $ do- reloadedSuccessfully "Ok, four modules loaded." `shouldBe` True- describe "removeProgress" $ do it "removes transient output" $ do (removeProgress . unlines) [@@ -111,8 +80,7 @@ withSession name [] $ \ session -> do writeFile name failingSpec (trigger session >> triggerAll session) `shouldReturn` (Failure, [- modulesLoaded Ok ["Spec"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✘]"@@ -122,28 +90,23 @@ , " Spec.hs:8:3: " , " 1) bar" , ""- , " To rerun use: --match \"/bar/\" --seed 0"- , "" , "Randomized with seed 0" , "" , "Finished in ..." , "2 examples, 1 failure"- , "Summary {summaryExamples = 2, summaryFailures = 1}" ]) describe "trigger" $ around withSomeSpec $ do it "reloads and runs specs" $ \ name -> do withSession name [] $ \ session -> do trigger session `shouldReturn` (Success, [- modulesLoaded Ok ["Spec"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]" , "" , "Finished in ..." , "2 examples, 0 failures"- , "Summary {summaryExamples = 2, summaryFailures = 0}" ]) context "with hooks" $ do@@ -151,15 +114,13 @@ withHooks $ \ hooks -> do withSession name [] $ \ session -> do triggerWithHooks session hooks `shouldReturn` (Success, [- modulesLoaded Ok ["Spec"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]" , "" , "Finished in ..." , "2 examples, 0 failures"- , "Summary {summaryExamples = 2, summaryFailures = 0}" ]) `shouldReturn` [BeforeReloadSucceeded, AfterReloadSucceeded] @@ -177,8 +138,7 @@ withHooks $ \ hooks -> do withSession name [] $ \ session -> do triggerWithHooks session hooks { afterReload = failingHook } `shouldReturn` (HookFailed, [- modulesLoaded Ok ["Spec"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" , "hook failed" ]) `shouldReturn` [BeforeReloadSucceeded]@@ -189,13 +149,17 @@ writeFile name (passingSpec ++ "foo = bar") (trigger session >> trigger session) `shouldReturn` (Failure, [ "[1 of 1] Compiling Spec"+#if __GLASGOW_HASKELL__ < 910 , ""+#endif #if __GLASGOW_HASKELL__ >= 906 , "Spec.hs:9:7: error: [GHC-88464] Variable not in scope: bar" #else , "Spec.hs:9:7: error: Variable not in scope: bar" #endif- , modulesLoaded Failed []+#if __GLASGOW_HASKELL__ >= 910+ , ""+#endif , withColor Red "RELOADING FAILED" ]) @@ -204,15 +168,29 @@ withSession name [] $ \ session -> do writeFile name failingSpec (Failure, xs) <- trigger session- xs `shouldContain` [modulesLoaded Ok ["Spec"]]- xs `shouldContain` ["2 examples, 1 failure"]+ xs `shouldBe` [+ "[1 of 1] Compiling Spec [Source file changed]"+ , withColor Green "RELOADING SUCCEEDED"+ , ""+ , "foo [✔]"+ , "bar [✘]"+ , ""+ , "Failures:"+ , ""+ , " Spec.hs:8:3: "+ , " 1) bar"+ , ""+ , "Randomized with seed 0"+ , ""+ , "Finished in ..."+ , "2 examples, 1 failure"+ ] it "only reruns failing specs" $ \ name -> do withSession name [] $ \ session -> do writeFile name failingSpec (trigger session >> trigger session) `shouldReturn` (Failure, [- modulesLoaded Ok ["Spec"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" , "" , "bar [✘]" , ""@@ -221,13 +199,10 @@ , " Spec.hs:8:3: " , " 1) bar" , ""- , " To rerun use: --match \"/bar/\" --seed 0"- , "" , "Randomized with seed 0" , "" , "Finished in ..." , "1 example, 1 failure"- , "Summary {summaryExamples = 1, summaryFailures = 1}" ]) context "after a failing spec passes" $ do@@ -237,49 +212,39 @@ _ <- trigger session writeFile name passingSpec trigger session `shouldReturn` (Success, [-#if __GLASGOW_HASKELL__ < 904- "[1 of 1] Compiling Spec"-#else "[1 of 1] Compiling Spec [Source file changed]"-#endif- , modulesLoaded Ok ["Spec"] , withColor Green "RELOADING SUCCEEDED" , "" , "bar [✔]" , "" , "Finished in ..." , "1 example, 0 failures"- , "Summary {summaryExamples = 1, summaryFailures = 0}" , "" , "foo [✔]" , "bar [✔]" , "" , "Finished in ..." , "2 examples, 0 failures"- , "Summary {summaryExamples = 2, summaryFailures = 0}" ]) context "with a module that does not expose a spec" $ do it "only reloads" $ \ name -> do withSession name [] $ \ session -> do- writeFile name "module Foo where"+ writeFile name "module Spec where" (trigger session >> trigger session) `shouldReturn` (Success, [- modulesLoaded Ok ["Foo"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" ]) context "with an hspec-meta spec" $ do it "reloads and runs spec" $ \ name -> do- requiresHspecMeta $ withSession name ["-package hspec-meta"] $ \ session -> do+ withSession name [] $ \ session -> do writeFile name passingMetaSpec (trigger session >> trigger session) `shouldReturn` (Success, [- modulesLoaded Ok ["Spec"]- , withColor Green "RELOADING SUCCEEDED"+ withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]" , "" , "Finished in ..." , "2 examples, 0 failures"- , "Summary {summaryExamples = 2, summaryFailures = 0}" ])
test/UtilSpec.hs view
@@ -2,6 +2,7 @@ import Helper +import qualified System.Console.ANSI as Ansi import System.Posix.Files import Util@@ -18,6 +19,13 @@ spec :: Spec spec = do+ describe "stripAnsi" $ do+ it "removes ANSI color sequences" $ do+ stripAnsi ("some " <> withColor Green "colorized" <> " text") `shouldBe` "some colorized text"++ it "removes DEC private mode sequences" $ do+ stripAnsi (Ansi.hideCursorCode <> "some text" <> Ansi.showCursorCode) `shouldBe` "some text"+ describe "isBoring" $ do it "ignores files in .git/" $ do isBoring "/foo/bar/.git/baz/foo.txt" `shouldBe` True@@ -38,7 +46,7 @@ describe "filterGitIgnoredFiles_" $ do it "discards files that are ignored by git" $ do withTempDirectory $ \ dir -> do- _ <- readProcess "git" ["-C", dir, "init"] ""+ _ <- readProcess "git" ["-C", dir, "init", "--initial-branch=main"] "" writeFile (dir </> ".gitignore") "foo" filterGitIgnoredFiles_ dir ["foo", "bar"] `shouldReturn` (Nothing, ["bar"])