leksah-server 0.16.2.0 → 0.16.3.0
raw patch · 6 files changed
+111/−188 lines, 6 filesdep −bin-package-dbdep −haddockdep ~Win32dep ~haddock-apidep ~haddock-library
Dependencies removed: bin-package-db, haddock
Dependency ranges changed: Win32, haddock-api, haddock-library, ltk
Files
- leksah-server.cabal +13/−87
- src/IDE/Metainfo/InterfaceCollector.hs +5/−2
- src/IDE/Metainfo/WorkspaceCollector.hs +5/−2
- src/IDE/Utils/CabalPlan.hs +1/−1
- src/IDE/Utils/FileUtils.hs +12/−5
- src/IDE/Utils/Tool.hs +75/−91
leksah-server.cabal view
@@ -1,5 +1,5 @@ name: leksah-server-version: 0.16.2.0+version: 0.16.3.0 cabal-version: >=1.10.2 build-type: Simple license: GPL@@ -40,51 +40,14 @@ haddock-library >=1.4.1 && <1.5, ghc-boot >=8.2.1 && <8.3 else-- if impl(ghc >=8.0)- build-depends:- haddock-api >=2.17.2 && <2.18,- haddock-library >=1.4.1 && <1.5,- ghc-boot >=8.0.1 && <8.1- else-- if impl(ghc >=7.10)- build-depends:- haddock-api >=2.16 && <2.17,- haddock-library >=1.2.0 && <1.3,- bin-package-db -any- else-- if impl(ghc >=7.8)- build-depends:- haddock-api >=2.7.2 && <2.16- else-- if impl(ghc >=7.6)- build-depends:- haddock >=2.7.2 && <2.14- else-- if impl(ghc >=7.4.2)- build-depends:- haddock >=2.11.1 && <2.12- else-- if impl(ghc >=7.4)- build-depends:- haddock >=2.7.2 && <2.11- else-- if impl(ghc >=7.2)- build-depends:- haddock >=2.7.2 && <2.10- else- build-depends:- haddock >=2.7.2 && <2.9.3+ build-depends:+ haddock-api >=2.17.2 && <2.18,+ haddock-library >=1.4.1 && <1.5,+ ghc-boot >=8.0.1 && <8.1 if os(windows) build-depends:- Win32 >=2.2.0.0 && <2.4+ Win32 >=2.2.0.0 && <2.6 extra-libraries: kernel32 pango-1.0@@ -130,7 +93,7 @@ executable-path >=0.0.3 && <0.1, directory >=1.0.0.2 && <1.4, filepath >=1.1.0.1 && <1.5,- ltk >=0.16.0.0 && <0.17,+ ltk >=0.16.2.0 && <0.17, parsec >=3.0.0.0 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.9,@@ -163,51 +126,14 @@ haddock-library >=1.4.1 && <1.5, ghc-boot >=8.2.1 && <8.3 else-- if impl(ghc >=8.0)- build-depends:- haddock-api >=2.17.2 && <2.18,- haddock-library >=1.4.1 && <1.5,- ghc-boot >=8.0.1 && <8.1- else-- if impl(ghc >=7.10)- build-depends:- haddock-api >=2.16 && <2.17,- haddock-library >=1.2.0 && <1.3,- bin-package-db -any- else-- if impl(ghc >=7.8)- build-depends:- haddock-api >=2.7.2 && <2.16- else-- if impl(ghc >=7.6)- build-depends:- haddock >=2.7.2 && <2.14- else-- if impl(ghc >=7.4.2)- build-depends:- haddock >=2.11.1 && <2.12- else-- if impl(ghc >=7.4)- build-depends:- haddock >=2.7.2 && <2.11- else-- if impl(ghc >=7.2)- build-depends:- haddock >=2.7.2 && <2.10- else- build-depends:- haddock >=2.7.2 && <2.9.3+ build-depends:+ haddock-api >=2.17.2 && <2.18,+ haddock-library >=1.4.1 && <1.5,+ ghc-boot >=8.0.1 && <8.1 if os(windows) build-depends:- Win32 >=2.2.0.0 && <2.4+ Win32 >=2.2.0.0 && <2.6 extra-libraries: kernel32 pango-1.0@@ -245,7 +171,7 @@ executable-path >=0.0.3 && <0.1, directory >=1.0.0.2 && <1.4, filepath >=1.1.0.1 && <1.5,- ltk >=0.16.0.0 && <0.17,+ ltk >=0.16.2.0 && <0.17, parsec >=3.0.0.0 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.9,
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -95,14 +95,17 @@ nameOccName82 :: Name -> OccName nameOccName82 = nameOccName #else-mkPackageName :: String -> PackageName-mkPackageName = PackageName nameOccName82 :: OccName -> OccName nameOccName82 = id flSelector :: OccName -> OccName flSelector = id ifConName :: IfaceConDecl -> OccName ifConName = ifConOcc+#endif++#if !MIN_VERSION_Cabal(2,0,0)+mkPackageName :: String -> PackageName+mkPackageName = PackageName #endif #if !MIN_VERSION_ghc(7,6,0)
src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -99,13 +99,16 @@ #endif #if !MIN_VERSION_ghc(8,2,0)-mkPackageName :: String -> PackageName-mkPackageName = PackageName ieWrappedName :: RdrName -> RdrName ieWrappedName = id type OutputableBndrId = OutputableBndr toInstalledUnitId :: GHC.UnitId -> GHC.UnitId toInstalledUnitId = id+#endif++#if !MIN_VERSION_Cabal(2,0,0)+mkPackageName :: String -> PackageName+mkPackageName = PackageName #endif type NDecl = LHsDecl RdrName
src/IDE/Utils/CabalPlan.hs view
@@ -108,7 +108,7 @@ doComps :: M.Map Text CompInfo -> [(Component, S.Set PID)] doComps m = sortOn fst [ (toComp k, S.fromList v) | (k,CompInfo v) <- M.toList m ] -data CompInfo = CompInfo [PID]+newtype CompInfo = CompInfo [PID] instance FromJSON CompInfo where parseJSON = withObject "CompInfo" $ \o -> CompInfo <$> o .: "depends"
src/IDE/Utils/FileUtils.hs view
@@ -447,11 +447,11 @@ Right plan -> return . map (,packageDBs) $ mapMaybe (T.simpleParse . T.unpack . piId) (pjPlan plan) -cabalProjectBuildDir :: FilePath -> IO (FilePath, FilePath -> FilePath)-cabalProjectBuildDir projectRoot = do- let distNewstyle = projectRoot </> "dist-newstyle"+cabalProjectBuildDir :: FilePath -> FilePath -> IO (FilePath, FilePath -> FilePath -> FilePath)+cabalProjectBuildDir projectRoot buildDir = do+ let distNewstyle = projectRoot </> buildDir planFile = distNewstyle </> "cache" </> "plan.json"- defaultDir = (distNewstyle </> "build", const "build")+ defaultDir = (distNewstyle </> "build", const $ const "build") doesFileExist planFile >>= \case False -> do debugM "leksah" $ "cabal plan not found : " <> planFile@@ -462,11 +462,18 @@ Right PlanJson { pjCabalVersion = v } | "1.24." `isPrefixOf` v -> return defaultDir Right PlanJson+ { pjCabalVersion = v+ , pjCompilerId = Just compilerId+ , pjOS = Just os+ , pjArch = Just arch+ } | "2.0." `isPrefixOf` v -> return (distNewstyle </> "build" </> arch <> "-" <> os </> compilerId,+ \_ctype component -> "c" </> component </> "build")+ Right PlanJson { pjCompilerId = Just compilerId , pjOS = Just os , pjArch = Just arch } -> return (distNewstyle </> "build" </> arch <> "-" <> os </> compilerId,- \component -> "c" </> component </> "build")+ \ctype component -> ctype </> component </> "build") Right plan -> do errorM "leksah" $ "Unexpected cabal plan : " <> show plan return defaultDir
src/IDE/Utils/Tool.hs view
@@ -31,6 +31,7 @@ newGhci', executeCommand, executeGhciCommand,+ interruptTool, quoteArg, escapeQuotes, runCommand,@@ -51,12 +52,13 @@ import Control.Applicative import Prelude import Control.Concurrent- (tryTakeMVar, readMVar, takeMVar, putMVar,+ (tryPutMVar, tryTakeMVar, readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan, getChanContents, dupChan)-import Control.Monad (when, unless)+import Control.Monad (void, forever, when, unless) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Maybe (fromMaybe)+import Data.Char (isDigit) import System.Process (showCommandForUser, proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..), interruptProcessGroupOf,@@ -72,26 +74,23 @@ (hClose, hFlush, Handle, hSetBuffering, BufferMode(..)) import System.Directory (getHomeDirectory) import System.FilePath (dropTrailingPathSeparator)+import System.Timeout (timeout) import Data.Conduit as C ((=$), ($$), ($=)) import qualified Data.Conduit as C import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Conduit.Text as CT (decode, utf8) import qualified Data.Conduit.List as CL- (consume, concatMap, concatMapAccumM, sequence, map)+ (concatMapAccumM, consume, concatMap, sequence, map) import qualified Data.Conduit.Binary as CB import Data.Conduit.Attoparsec (sinkParser) import qualified Data.Attoparsec.Text as AP- (isEndOfLine, isHorizontalSpace, skipWhile, endOfInput, takeWhile,- satisfy, string, Parser, endOfLine, digit, manyTill, takeWhile1,- char)+ (endOfInput, takeWhile, Parser, endOfLine, char, string) import Data.Attoparsec.Text ((<?>))-import Data.Char (isDigit) import Data.Text (replace, Text) import Data.Monoid ((<>)) import Data.Text.IO (hPutStrLn) import Data.List (stripPrefix)-import Control.Arrow (Arrow(..)) #ifdef MIN_VERSION_unix import System.Posix.Signals (emptySignalSet, sigINT, addSignal, unblockSignals)@@ -122,7 +121,8 @@ outputClosed :: MVar Bool, toolCommands :: Chan ToolCommand, toolCommandsRead :: Chan ToolCommand,- currentToolCommand :: MVar ToolCommand}+ currentToolCommand :: MVar ToolCommand,+ interruptToolMVar :: MVar ()} toolProcess :: ToolState -> IO ProcessHandle toolProcess = readMVar . toolProcessMVar@@ -192,6 +192,7 @@ toolCommands <- newChan toolCommandsRead <- dupChan toolCommands currentToolCommand <- newEmptyMVar+ interruptToolMVar <- newEmptyMVar return ToolState{..} isolateToFirst :: Monad m => (o -> Bool) -> C.ConduitM o o m ()@@ -219,6 +220,9 @@ #endif putMVar (toolProcessMVar tool) pid output <- getOutput clr inp out err pid+ _ <- forkIO . forever $ do+ takeMVar $ interruptToolMVar tool+ interruptProcessGroupOf pid _ <- forkIO $ do case initialCommand clr of@@ -276,6 +280,23 @@ debugM "leksah-server" $ "Unexpected output " ++ show x return (s, []) +-- outputSequence :: C.Conduit RawToolOutput IO ToolOutput+-- outputSequence =+-- CL.concatMapM writeCommandOutput+-- where+-- writeCommandOutput (RawToolOutput (ToolPrompt line)) = do+-- debugM "leksah-server" "Sync Prompt"+-- _ <- tryTakeMVar (currentToolCommand tool)+-- return [ToolPrompt line]+-- writeCommandOutput (RawToolOutput o@(ToolExit _)) = do+-- debugM "leksah-server" "Tool Exit"+-- putMVar (outputClosed tool) True+-- return [o]+-- writeCommandOutput (RawToolOutput o) = return [o]+-- writeCommandOutput x = do+-- debugM "leksah-server" $ "Unexpected output " ++ show x+-- return []+ {- newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [Text] -> IO ToolState newInteractiveTool getOutput' executable arguments = do@@ -285,27 +306,24 @@ -} ghciPrompt :: Text-ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"+ghciPrompt = "\0" data CommandLineReader = CommandLineReader { initialCommand :: Maybe Text, parseInitialPrompt :: AP.Parser Text, parseFollowingPrompt :: AP.Parser Text,- errorSyncCommand :: Maybe (Int -> Text),- parseExpectedError :: AP.Parser (Text, Int),+ errorSyncCommand :: Maybe Text,+ parseExpectedError :: AP.Parser Text, outputSyncCommand :: Maybe (Int -> Text), isExpectedOutput :: Int -> Text -> Bool } -ghciParseInitialPrompt :: AP.Parser Text-ghciParseInitialPrompt = (- T.pack <$> AP.satisfy (/= '\n') `AP.manyTill` AP.string ghciPrompt)- <?> "ghciParseInitialPrompt"--ghciParseFollowingPrompt :: AP.Parser Text-ghciParseFollowingPrompt = (- T.pack <$> AP.satisfy (/= '\n') `AP.manyTill` AP.string ghciPrompt)- <?> "ghciParseFollowingPrompt"+ghciParsePrompt :: AP.Parser Text+ghciParsePrompt = (do+ t <- AP.takeWhile (\ c -> c /= '\n' && c /= '\0')+ _ <- AP.char '\0'+ return t)+ <?> "ghciParsePrompt" marker :: Int -> Text marker n = "kMAKWRALZ" <> T.pack (show n)@@ -317,48 +335,6 @@ return . read $ T.unpack nums) <?> "parseMarker" -ghciParseExpectedErrorCols :: AP.Parser ()-ghciParseExpectedErrorCols = (do- _ <- AP.string $ T.pack "0-"- _ <- AP.digit- _ <- AP.digit- return ())- <|> (do- _ <- AP.string $ T.pack "1-"- _ <- AP.digit- _ <- AP.digit- return ())- <|> (do- _ <- AP.string $ T.pack "0"- return ())- <|> (do- _ <- AP.string $ T.pack "1"- return ())- <?> "ghciParseExpectedErrorCols"--manyTill' :: Alternative f => f a -> f b -> f ([a], b)-manyTill' p end = scan- where scan = liftA (\b -> ([], b)) end <|> liftA2 (\a (as, b) -> (a:as, b)) p scan--ghciParseExpectedError :: AP.Parser (Text, Int)-ghciParseExpectedError = (- first T.pack <$> AP.satisfy (/='\n') `manyTill'` (do- _ <- AP.string "\n<interactive>:"- _ <- AP.takeWhile1 isDigit- _ <- AP.string ":"- ghciParseExpectedErrorCols- _ <- AP.string ":"- _ <- AP.skipWhile (\c -> AP.isHorizontalSpace c || AP.isEndOfLine c)- _ <- AP.string "Not in scope: " <|> AP.string "error: Variable not in scope: "- result <- (do- _ <- AP.char '`' <|> AP.char '‛' <|> AP.char '‘'- m <- parseMarker- _ <- AP.char '\'' <|> AP.char '’'- return m) <|> parseMarker- _ <- AP.string "\n"- return result))- <?> "ghciParseExpectedError"- ghciIsExpectedOutput :: Int -> Text -> Bool ghciIsExpectedOutput n = (==) (marker n)@@ -366,10 +342,10 @@ ghciCommandLineReader :: CommandLineReader ghciCommandLineReader = CommandLineReader { initialCommand = Just $ ":set prompt " <> ghciPrompt,- parseInitialPrompt = ghciParseInitialPrompt,- parseFollowingPrompt = ghciParseFollowingPrompt,- errorSyncCommand = Just $ \count -> marker count,- parseExpectedError = ghciParseExpectedError,+ parseInitialPrompt = ghciParsePrompt,+ parseFollowingPrompt = ghciParsePrompt,+ errorSyncCommand = Just "_ <- System.IO.hPutStr System.IO.stderr \"\\0\"",+ parseExpectedError = ghciParsePrompt, outputSyncCommand = Just $ \count -> ":set prompt \"" <> marker count <> "\\n\"\n:set prompt " <> ghciPrompt, isExpectedOutput = ghciIsExpectedOutput }@@ -385,7 +361,7 @@ isExpectedOutput = \_ _ -> False } -parseError :: AP.Parser (Text, Int) -> AP.Parser (Either (Text, Int) Text)+parseError :: AP.Parser Text -> AP.Parser (Either Text Text) parseError expectedErrorParser = (do expected <- expectedErrorParser return $ Left expected)@@ -425,10 +401,11 @@ else loop nowClosed loop _ = error "Error in enumOutput" - readError :: MVar RawToolOutput -> Handle -> MVar Int -> IO ()+ readError :: MVar RawToolOutput -> Handle -> MVar () -> IO () readError mvar errors foundExpectedError = do CB.sourceHandle errors $= CT.decode CT.utf8 $= CL.map (T.filter (/= '\r'))+-- $= CL.map (\x -> trace ("E : " <> show x) x) $= CL.sequence (sinkParser (parseError $ parseExpectedError clr)) $$ sendErrors hClose errors@@ -436,9 +413,9 @@ sendErrors = C.awaitForever $ \x -> liftIO $ do debugM "leksah-server" $ show x case x of- Left (line, counter) -> do+ Left line -> do unless (T.null line) $ putMVar mvar $ RawToolOutput $ ToolError line- putMVar foundExpectedError counter+ void $ tryPutMVar foundExpectedError () Right line -> putMVar mvar $ RawToolOutput $ ToolError line outputSequence :: AP.Parser ToolOutput -> AP.Parser ToolOutput -> C.Conduit Text IO ToolOutput@@ -448,7 +425,7 @@ check line@(ToolPrompt _) = C.yield line >> CL.sequence (sinkParser i2) check line = C.yield line >> loop - readOutput :: MVar RawToolOutput -> Handle -> MVar Int -> IO ()+ readOutput :: MVar RawToolOutput -> Handle -> MVar () -> IO () readOutput mvar output foundExpectedError = do let parseLines parsePrompt = (do lineSoFar <- parsePrompt@@ -466,40 +443,36 @@ $$ sendErrors hClose output where- sendErrors = loop 0 False ""+ sendErrors = loop True False "" where- loop counter errSynced promptLine = do+ loop first errSynced promptLine = do mbx <- C.await liftIO $ debugM "leksah-server" $ "sendErrors " ++ show mbx case mbx of Nothing -> return () Just x@(ToolPrompt line) ->- case (counter, errSynced, errorSyncCommand clr) of- (0, _, _) ->- loop (counter+1) errSynced line+ case (first, errSynced, errorSyncCommand clr) of+ (True, _, _) ->+ loop False errSynced line (_, False, Just syncCmd) -> do liftIO $ do- let errN = counter `rem` 10- debugM "leksah-server" $ "sendErrors - Sync " ++ T.unpack (syncCmd errN)- hPutStrLn inp $ syncCmd errN+ debugM "leksah-server" $ "sendErrors - Sync " ++ T.unpack syncCmd+ hPutStrLn inp syncCmd hFlush inp- waitForError errN- debugM "leksah-server" $ "sendErrors - Synced " ++ show errN- loop (counter+1) True line+ _ <- timeout 10000000 waitForError+ debugM "leksah-server" "sendErrors - Synced"+ loop False True line (_, True, Just _) -> do liftIO $ putMVar mvar $ RawToolOutput (ToolPrompt promptLine)- loop (counter+1) False promptLine+ loop False False promptLine _ -> do liftIO $ putMVar mvar $ RawToolOutput x- loop (counter+1) False promptLine+ loop False False promptLine Just x -> do liftIO . putMVar mvar $ RawToolOutput x- loop counter errSynced promptLine+ loop first errSynced promptLine - waitForError counter = do- foundCount <- takeMVar foundExpectedError- debugM "leksah-server" $ "waitForError - Found " ++ show foundCount- when (foundCount < counter) $ waitForError counter+ waitForError = takeMVar foundExpectedError fromRawOutput :: RawToolOutput -> [ToolOutput]@@ -522,8 +495,16 @@ newGhci :: FilePath -> [Text] -> FilePath -> [Text] -> C.Sink ToolOutput IO () -> IO ToolState newGhci executable arguments dir interactiveFlags startupOutputHandler = do tool <- newToolState+ home <- liftIO getHomeDirectory+ let friendlyDir d = case stripPrefix home d of+ Just rest -> "~" <> rest+ Nothing -> d+ debugM "leksah-server" $ "newGhci " <>+ friendlyDir (dropTrailingPathSeparator dir) <> "$ " <> showCommandForUser executable (map T.unpack arguments)+ writeChan (toolCommands tool) $- ToolCommand (":set " <> T.unwords interactiveFlags <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler+ ToolCommand (":set prompt " <> ghciPrompt) "" startupOutputHandler+ executeGhciCommand tool (":set " <> T.unwords interactiveFlags) startupOutputHandler runInteractiveTool tool ghciCommandLineReader executable arguments (Just dir) return tool @@ -542,6 +523,9 @@ safeLine ":{" = False safeLine ":}" = False safeLine _ = True++interruptTool :: ToolState -> IO ()+interruptTool tool = putMVar (interruptToolMVar tool) () --children :: MVar [MVar ()] --children = unsafePerformIO (newMVar [])