hdevtools 0.1.4.1 → 0.1.5.0
raw patch · 9 files changed
+133/−106 lines, 9 files
Files
- CHANGELOG.md +5/−0
- hdevtools.cabal +1/−1
- src/CommandArgs.hs +12/−0
- src/CommandLoop.hs +96/−59
- src/FindSymbol.hs +6/−31
- src/Info.hs +4/−13
- src/Main.hs +2/−1
- src/Stack.hs +5/−1
- src/Types.hs +2/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Changelog +## 0.1.5.0 - 2016-12-23++ * (Re-)added template haskell support when required. Can be turned off using `--noTH`.+ * Fixed system installed GHC libdir paths using stack.+ ## 0.1.4.1 - 2016-09-04 * Do not try to execute `stack` commands if not available.
hdevtools.cabal view
@@ -1,5 +1,5 @@ name: hdevtools-version: 0.1.4.1+version: 0.1.5.0 synopsis: Persistent GHC powered background server for FAST haskell development tools license: MIT license-file: LICENSE
src/CommandArgs.hs view
@@ -50,6 +50,7 @@ , file :: String , json :: Bool , debug :: Bool+ , noTH :: Bool } | ModuleFile { socket :: Maybe FilePath@@ -66,6 +67,7 @@ , file :: String , identifier :: String , debug :: Bool+ , noTH :: Bool } | Type { socket :: Maybe FilePath@@ -76,6 +78,7 @@ , line :: Int , col :: Int , debug :: Bool+ , noTH :: Bool } | FindSymbol { socket :: Maybe FilePath@@ -84,6 +87,7 @@ , symbol :: String , files :: [String] , debug :: Bool+ , noTH :: Bool } deriving (Show, Data, Typeable) @@ -108,6 +112,7 @@ , file = "" , json = False , debug = False+ , noTH = False } dummyModuleFile :: HDevTools@@ -128,6 +133,7 @@ , file = "" , identifier = "" , debug = False+ , noTH = False } dummyType :: HDevTools@@ -140,6 +146,7 @@ , line = 0 , col = 0 , debug = False+ , noTH = False } dummyFindSymbol :: HDevTools@@ -150,6 +157,7 @@ , symbol = "" , files = [] , debug = False+ , noTH = False } admin :: Annotate Ann@@ -173,6 +181,7 @@ , file := def += typFile += argPos 0 += opt "" , json := def += help "render output as JSON" , debug := def += help "enable debug output"+ , noTH := def += help "disable template haskell" ] += help "Check a haskell source file for errors and warnings" moduleFile :: Annotate Ann@@ -193,6 +202,7 @@ , file := def += typFile += argPos 0 += opt "" , identifier := def += typ "IDENTIFIER" += argPos 1 , debug := def += help "enable debug output"+ , noTH := def += help "disable template haskell" ] += help "Get info from GHC about the specified identifier" type_ :: Annotate Ann@@ -205,6 +215,7 @@ , file := def += typFile += argPos 0 += opt "" , line := def += typ "LINE" += argPos 1 , col := def += typ "COLUMN" += argPos 2+ , noTH := def += help "disable template haskell" ] += help "Get the type of the expression at the specified line and column" findSymbol :: Annotate Ann@@ -215,6 +226,7 @@ , symbol := def += typ "SYMBOL" += argPos 0 , files := def += typFile += args , debug := def += help "enable debug output"+ , noTH := def += help "disable template haskell" ] += help "List the modules where the given symbol could be found" full :: String -> Annotate Ann
src/CommandLoop.hs view
@@ -8,7 +8,7 @@ ) where import Control.Applicative ((<|>))-import Control.Monad (when)+import Control.Monad (when, void) import Data.IORef import Data.List (find, intercalate) #if __GLASGOW_HASKELL__ < 709@@ -67,6 +67,7 @@ { configGhcOpts :: [String] , configCabal :: Maybe CabalConfig , configStack :: Maybe StackConfig+ , configTH :: Bool } deriving (Eq, Show) @@ -82,6 +83,7 @@ return $ Config { configGhcOpts = "-O0" : ceGhcOptions cmdExtra , configCabal = mbCabalConfig , configStack = mbStackConfig+ , configTH = ceTemplateHaskell cmdExtra } where msc = mConfig >>= configStack@@ -112,7 +114,7 @@ ] processNextCommand True Right _ -> do- doMaybe mbInitialCommand $ \cmd -> sendErrors (runCommand state clientSend cmd)+ doMaybe mbInitialCommand $ \cmd -> sendErrors (runCommand state clientSend initialConfig cmd) processNextCommand False case continue of@@ -134,7 +136,7 @@ Just (cmd, config) -> if forceReconfig || (config /= initialConfig) then return (Just (cmd, config))- else sendErrors (runCommand state clientSend cmd) >> processNextCommand False+ else sendErrors (runCommand state clientSend initialConfig cmd) >> processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc () sendErrors action = GHC.gcatch action $ \e -> do@@ -178,17 +180,37 @@ handleGhcError :: GHC.GhcException -> GHC.Ghc String handleGhcError e = return $ GHC.showGhcException e "" -runCommand :: IORef State -> ClientSend -> Command -> GHC.Ghc ()-runCommand _ clientSend (CmdCheck file) = do+loadTarget :: [FilePath] -> Config -> GHC.Ghc (Maybe GHC.SuccessFlag)+loadTarget files conf = do let noPhase = Nothing- target <- GHC.guessTarget file noPhase- GHC.setTargets [target]- let handler err = GHC.printException err >> return GHC.Failed- flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets)- liftIO $ case flag of- GHC.Succeeded -> clientSend (ClientExit ExitSuccess)- GHC.Failed -> clientSend (ClientExit (ExitFailure 1))-runCommand _ clientSend (CmdModuleFile moduleName) = do+ targets <- mapM (flip GHC.guessTarget noPhase) files+ GHC.setTargets targets+ graph <- GHC.depanal [] True+ if configTH conf || (not $ GHC.needsTemplateHaskell graph)+ then do+ when (GHC.needsTemplateHaskell graph) $ do+ flags <- GHC.getSessionDynFlags+ void . GHC.setSessionDynFlags $ flags { GHC.hscTarget = GHC.HscInterpreted, GHC.ghcLink = GHC.LinkInMemory }+ let handler err = GHC.printException err >> return GHC.Failed+ fmap Just $ GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets)+ else return Nothing++withTargets :: ClientSend -> [FilePath] -> Config -> GHC.Ghc () -> GHC.Ghc ()+withTargets clientSend files conf act = do+ ret <- loadTarget files conf+ case ret of+ Nothing -> liftIO $ mapM_ clientSend [ClientStderr "Template haskell required but not activated", ClientExit (ExitFailure 1)]++ Just GHC.Failed -> liftIO $ mapM_ clientSend [ClientStderr "Failed to load targets", ClientExit (ExitFailure 1)]++ Just GHC.Succeeded -> act+++runCommand :: IORef State -> ClientSend -> Config -> Command -> GHC.Ghc ()+runCommand _ clientSend conf (CmdCheck file) =+ withTargets clientSend [file] conf+ (liftIO . clientSend . ClientExit $ ExitSuccess)+runCommand _ clientSend _ (CmdModuleFile moduleName) = do moduleGraph <- GHC.getModuleGraph case find (moduleSummaryMatchesModuleName moduleName) moduleGraph of Nothing ->@@ -211,54 +233,69 @@ where moduleSummaryMatchesModuleName modName modSummary = modName == (GHC.moduleNameString . GHC.moduleName . GHC.ms_mod) modSummary-runCommand state clientSend (CmdInfo file identifier) = do- result <- withWarnings state False $- getIdentifierInfo file identifier- case result of- Left err ->- liftIO $ mapM_ clientSend- [ ClientStderr err- , ClientExit (ExitFailure 1)+runCommand state clientSend conf (CmdInfo file identifier) =+ withTargets clientSend [file] conf $ do+ result <- withWarnings state False $+ getIdentifierInfo file identifier+ case result of+ Left err ->+ liftIO $ mapM_ clientSend+ [ ClientStderr err+ , ClientExit (ExitFailure 1)+ ]+ Right info -> liftIO $ mapM_ clientSend+ [ ClientStdout info+ , ClientExit ExitSuccess ]- Right info -> liftIO $ mapM_ clientSend- [ ClientStdout info- , ClientExit ExitSuccess- ]-runCommand state clientSend (CmdType file (line, col)) = do- result <- withWarnings state False $- getType file (line, col)- case result of- Left err ->- liftIO $ mapM_ clientSend- [ ClientStderr err- , ClientExit (ExitFailure 1)+runCommand state clientSend conf (CmdType file (line, col)) =+ withTargets clientSend [file] conf $ do+ result <- withWarnings state False $+ getType file (line, col)+ case result of+ Left err ->+ liftIO $ mapM_ clientSend+ [ ClientStderr err+ , ClientExit (ExitFailure 1)+ ]+ Right types -> liftIO $ do+ mapM_ (clientSend . ClientStdout . formatType) types+ clientSend (ClientExit ExitSuccess)+ where+ formatType :: ((Int, Int, Int, Int), String) -> String+ formatType ((startLine, startCol, endLine, endCol), t) =+ concat+ [ show startLine , " "+ , show startCol , " "+ , show endLine , " "+ , show endCol , " "+ , "\"", t, "\"" ]- Right types -> liftIO $ do- mapM_ (clientSend . ClientStdout . formatType) types- clientSend (ClientExit ExitSuccess)- where- formatType :: ((Int, Int, Int, Int), String) -> String- formatType ((startLine, startCol, endLine, endCol), t) =- concat- [ show startLine , " "- , show startCol , " "- , show endLine , " "- , show endCol , " "- , "\"", t, "\""- ]-runCommand state clientSend (CmdFindSymbol symbol files) = do- result <- withWarnings state False $ findSymbol symbol files- case result of- [] -> liftIO $ mapM_ clientSend- [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'"- , ClientExit (ExitFailure 1)- ]- modules -> liftIO $ mapM_ clientSend- [ ClientStdout (formatModules modules)- , ClientExit ExitSuccess- ]- where- formatModules = intercalate "\n"+runCommand state clientSend conf (CmdFindSymbol symbol files) = do+ -- for the findsymbol command GHC shouldn't output any warnings+ -- or errors to stdout for the loaded source files, we're only+ -- interested in the module graph of the loaded targets+ dynFlags <- GHC.getSessionDynFlags+ _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ ->+#if __GLASGOW_HASKELL__ >= 800+ return . return $ () }+#else+ return () }+#endif++ ret <- withTargets clientSend files conf $ do+ result <- withWarnings state False $ findSymbol symbol+ case result of+ [] -> liftIO $ mapM_ clientSend+ [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'"+ , ClientExit (ExitFailure 1)+ ]+ modules -> liftIO $ mapM_ clientSend+ [ ClientStdout (intercalate "\n" modules)+ , ClientExit ExitSuccess+ ]+ -- reset the old log_action+ _ <- GHC.setSessionDynFlags dynFlags+ return ret
src/FindSymbol.hs view
@@ -24,42 +24,17 @@ type SymbolName = String type ModuleName = String -findSymbol :: SymbolName -> [FilePath] -> GHC.Ghc [ModuleName]-findSymbol symbol files = do- -- for the findsymbol command GHC shouldn't output any warnings- -- or errors to stdout for the loaded source files, we're only- -- interested in the module graph of the loaded targets- dynFlags <- GHC.getSessionDynFlags- _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ ->-#if __GLASGOW_HASKELL__ >= 800- return . return $ () }-#else- return () }-#endif-- fileMods <- concat <$> mapM (findSymbolInFile symbol) files-- -- reset the old log_action- _ <- GHC.setSessionDynFlags dynFlags+findSymbol :: SymbolName -> GHC.Ghc [ModuleName]+findSymbol symbol = do+ fileMods <- findSymbolInFile symbol pkgsMods <- findSymbolInPackages symbol return . nub . map (GHC.moduleNameString . GHC.moduleName) $ fileMods ++ pkgsMods -findSymbolInFile :: SymbolName -> FilePath -> GHC.Ghc [GHC.Module]-findSymbolInFile symbol file = do- loadFile- filterM (containsSymbol symbol) =<< fileModules- where- loadFile = do- let noPhase = Nothing- target <- GHC.guessTarget file noPhase- GHC.setTargets [target]- let handler err = GHC.printException err >> return GHC.Failed- _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets)- return ()-- fileModules = map GHC.ms_mod <$> GHC.getModuleGraph+findSymbolInFile :: SymbolName -> GHC.Ghc [GHC.Module]+findSymbolInFile symbol =+ filterM (containsSymbol symbol) =<< map GHC.ms_mod <$> GHC.getModuleGraph findSymbolInPackages :: SymbolName -> GHC.Ghc [GHC.Module]
src/Info.hs view
@@ -52,19 +52,10 @@ withModSummary :: String -> (HscTypes.ModSummary -> GHC.Ghc (Either String a)) -> GHC.Ghc (Either String a) withModSummary file action = do- let noPhase = Nothing- target <- GHC.guessTarget file noPhase- GHC.setTargets [target]-- let handler err = GHC.printException err >> return GHC.Failed- flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets)- case flag of- GHC.Failed -> return (Left "Error loading targets")- GHC.Succeeded -> do- modSummary <- getModuleSummary file- case modSummary of- Nothing -> return (Left "Module not found in module graph")- Just m -> action m+ modSummary <- getModuleSummary file+ case modSummary of+ Nothing -> return (Left "Module not found in module graph")+ Just m -> action m getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary) getModuleSummary file = do
src/Main.hs view
@@ -110,7 +110,8 @@ | otherwise = do absFile <- absoluteFilePath $ file args let args' = args { file = absFile }- serverCommand sock (cmd args') extra+ extra' = extra { ceTemplateHaskell = not (noTH args) }+ serverCommand sock (cmd args') extra' doCheck :: FilePath -> HDevTools -> CommandExtra -> IO () doCheck = doFileCommand "check" $
src/Stack.hs view
@@ -52,7 +52,11 @@ getStackGhcBinDir = fmap (fmap trim) . execStackInPath "path --compiler-bin" getStackGhcLibDir :: FilePath -> IO (Maybe FilePath)-getStackGhcLibDir = fmap (fmap takeDirectory) . execStackInPath "path --global-pkg-db"+getStackGhcLibDir p = do+ ghc <- (trim <$>) <$> execStackInPath "path --compiler-exe" p+ case ghc of+ Just exe -> (trim <$>) <$> execInPath (exe ++ " --print-libdir") p+ Nothing -> return Nothing getStackDist :: FilePath -> IO (Maybe FilePath) getStackDist p = (trim <$>) <$> execStackInPath "path --dist-dir" p
src/Types.hs view
@@ -14,6 +14,7 @@ , ceCabalFilePath :: Maybe FilePath , ceCabalOptions :: [String] , ceStackYamlPath :: Maybe FilePath+ , ceTemplateHaskell :: Bool } deriving (Read, Show) emptyCommandExtra :: CommandExtra@@ -22,6 +23,7 @@ , ceCabalFilePath = Nothing , ceCabalOptions = [] , ceStackYamlPath = Nothing+ , ceTemplateHaskell = True } data ServerDirective