diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2016 Simon Hengel +Copyright (c) 2015-2025 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/driver/seito.hs b/driver/seito.hs --- a/driver/seito.hs +++ b/driver/seito.hs @@ -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 diff --git a/driver/sensei-web.hs b/driver/sensei-web.hs --- a/driver/sensei-web.hs +++ b/driver/sensei-web.hs @@ -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 diff --git a/driver/sensei.hs b/driver/sensei.hs --- a/driver/sensei.hs +++ b/driver/sensei.hs @@ -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 diff --git a/sensei.cabal b/sensei.cabal --- a/sensei.cabal +++ b/sensei.cabal @@ -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 maintainer: Simon Hengel 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 diff --git a/src/Client.hs b/src/Client.hs --- a/src/Client.hs +++ b/src/Client.hs @@ -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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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) diff --git a/src/Config/DeepSeek.hs b/src/Config/DeepSeek.hs new file mode 100644 --- /dev/null +++ b/src/Config/DeepSeek.hs @@ -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 diff --git a/src/DeepSeek.hs b/src/DeepSeek.hs new file mode 100644 --- /dev/null +++ b/src/DeepSeek.hs @@ -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 diff --git a/src/DeepSeek/Types.hs b/src/DeepSeek/Types.hs new file mode 100644 --- /dev/null +++ b/src/DeepSeek/Types.hs @@ -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) diff --git a/src/GHC/Diagnostic.hs b/src/GHC/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Diagnostic.hs @@ -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 diff --git a/src/GHC/Diagnostic/Type.hs b/src/GHC/Diagnostic/Type.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Diagnostic/Type.hs @@ -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 -> "" + 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 diff --git a/src/HTTP.hs b/src/HTTP.hs --- a/src/HTTP.hs +++ b/src/HTTP.hs @@ -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")] diff --git a/src/HTTP/Util.hs b/src/HTTP/Util.hs new file mode 100644 --- /dev/null +++ b/src/HTTP/Util.hs @@ -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 diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -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 diff --git a/src/Language/Haskell/GhciWrapper.hs b/src/Language/Haskell/GhciWrapper.hs --- a/src/Language/Haskell/GhciWrapper.hs +++ b/src/Language/Haskell/GhciWrapper.hs @@ -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) diff --git a/src/ReadHandle.hs b/src/ReadHandle.hs --- a/src/ReadHandle.hs +++ b/src/ReadHandle.hs @@ -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 diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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 } diff --git a/src/Sensei/API.hs b/src/Sensei/API.hs new file mode 100644 --- /dev/null +++ b/src/Sensei/API.hs @@ -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" } diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -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" diff --git a/src/Trigger.hs b/src/Trigger.hs --- a/src/Trigger.hs +++ b/src/Trigger.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -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' -> "->" diff --git a/startup.ghci b/startup.ghci deleted file mode 100644 --- a/startup.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set prompt "" -:unset +m +r +s +t +c -:seti -XHaskell2010 -:seti -XNoOverloadedStrings diff --git a/test/ClientSpec.hs b/test/ClientSpec.hs --- a/test/ClientSpec.hs +++ b/test/ClientSpec.hs @@ -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") diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs --- a/test/ConfigSpec.hs +++ b/test/ConfigSpec.hs @@ -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 diff --git a/test/DeepSeekSpec.hs b/test/DeepSeekSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeepSeekSpec.hs @@ -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" + ] + } diff --git a/test/EventQueueSpec.hs b/test/EventQueueSpec.hs --- a/test/EventQueueSpec.hs +++ b/test/EventQueueSpec.hs @@ -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 diff --git a/test/GHC/DiagnosticSpec.hs b/test/GHC/DiagnosticSpec.hs new file mode 100644 --- /dev/null +++ b/test/GHC/DiagnosticSpec.hs @@ -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" + ] diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs --- a/test/HTTPSpec.hs +++ b/test/HTTPSpec.hs @@ -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" + , "}" + ] + } diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -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 diff --git a/test/Language/Haskell/GhciWrapperSpec.hs b/test/Language/Haskell/GhciWrapperSpec.hs --- a/test/Language/Haskell/GhciWrapperSpec.hs +++ b/test/Language/Haskell/GhciWrapperSpec.hs @@ -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, []) diff --git a/test/ReadHandleSpec.hs b/test/ReadHandleSpec.hs --- a/test/ReadHandleSpec.hs +++ b/test/ReadHandleSpec.hs @@ -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"] diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -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 diff --git a/test/SessionSpec.hs b/test/SessionSpec.hs --- a/test/SessionSpec.hs +++ b/test/SessionSpec.hs @@ -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) diff --git a/test/SpecHook.hs b/test/SpecHook.hs --- a/test/SpecHook.hs +++ b/test/SpecHook.hs @@ -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 diff --git a/test/TriggerSpec.hs b/test/TriggerSpec.hs --- a/test/TriggerSpec.hs +++ b/test/TriggerSpec.hs @@ -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}" ]) diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs --- a/test/UtilSpec.hs +++ b/test/UtilSpec.hs @@ -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"])