hdevtools · jrp2014 · Jan 13, 2019 · Jan 13, 2019 · ch1bo · Jan 14, 2019
diff --git a/hdevtools.cabal b/hdevtools.cabal
@@ -1,5 +1,5 @@
 name:                hdevtools
-version:             0.1.7.0
+version:             0.1.7.1
 synopsis:            Persistent GHC powered background server for FAST haskell development tools
 license:             MIT
 license-file:        LICENSE

diff --git a/src/Cabal.hs b/src/Cabal.hs
@@ -11,6 +11,7 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State (execStateT, modify)
 import Data.Char (isSpace)
 import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf)
+import Data.Maybe (isJust)
 #if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ((<$>))
 import Data.Monoid (Monoid(..))
@@ -91,9 +92,9 @@ stackifyFlags cfg (Just si) = cfg { configHcPath = toFlag ghc
 -- cabal configure --package-db=clear --package-db=global --package-db=$(stack path --snapshot-pkg-db) --package-db=$(stack path --local-pkg-db)
 
 getPackageGhcOpts :: FilePath -> Maybe StackConfig -> [String] -> IO (Either String [String])
-getPackageGhcOpts path mbStack opts = do
-    getPackageGhcOpts' `catch` (\e -> do
-        return $ Left $ "Cabal error: " ++ (ioeGetErrorString (e :: IOException)))
+getPackageGhcOpts path mbStack opts =
+    getPackageGhcOpts' `catch` (\e ->
+        return $ Left $ "Cabal error: " ++ ioeGetErrorString (e :: IOException))
   where
     getPackageGhcOpts' :: IO (Either String [String])
     getPackageGhcOpts' = do
@@ -118,7 +119,7 @@ getPackageGhcOpts path mbStack opts = do
           let sandboxConfig = takeDirectory path </> "cabal.sandbox.config"
 
           exists <- lift $ doesFileExist sandboxConfig
-          when (exists) $ do
+          when exists $ do
             sandboxPackageDb <- lift $ getSandboxPackageDB sandboxConfig
             modify $ \x -> x { configPackageDBs = [Just sandboxPackageDb] }
 
@@ -138,13 +139,19 @@ getPackageGhcOpts path mbStack opts = do
                 let mbLibName = pkgLibName pkgDescr
 #endif
                 let ghcOpts' = foldl' mappend mempty . map (getComponentGhcOptions localBuildInfo) .
-                               flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo
+                               flip allComponentsBy id . localPkgDescr $ localBuildInfo
                     -- FIX bug in GhcOptions' `mappend`
-#if MIN_VERSION_Cabal(1,21,1)
+#if MIN_VERSION_Cabal(2,0,0)
+-- API Change, just for the glory of Satan:
+-- Distribution.Simple.Program.GHC.GhcOptions no longer uses NubListR's
+                    ghcOpts = ghcOpts' { ghcOptExtra = filter (/= "-Werror") $ ghcOptExtra ghcOpts'
+#elif MIN_VERSION_Cabal(1,21,1)
 -- API Change:
 -- Distribution.Simple.Program.GHC.GhcOptions now uses NubListR's
 --  GhcOptions { .. ghcOptPackages :: NubListR (InstalledPackageId, PackageId, ModuleRemaining) .. }
                     ghcOpts = ghcOpts' { ghcOptExtra = overNubListR (filter (/= "-Werror")) $ ghcOptExtra ghcOpts'
+#endif
+#if MIN_VERSION_Cabal(1,21,1)
 #if __GLASGOW_HASKELL__ >= 709
                                        , ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts')
 #endif
@@ -199,7 +206,7 @@ pkgLibName pkgDescr = if hasLibrary pkgDescr
 #endif
 
 hasLibrary :: PackageDescription -> Bool
-hasLibrary = maybe False (\_ -> True) . library
+hasLibrary = isJust . library
 
 getComponentGhcOptions :: LocalBuildInfo -> Component -> GhcOptions
 getComponentGhcOptions lbi comp =
@@ -221,9 +228,8 @@ getSandboxPackageDB sandboxPath = do
   where
     pkgDbKey = "package-db:"
     parse = head . filter (pkgDbKey `isPrefixOf`) . lines
-    extractValue = fst . break (`elem` "\n\r") . dropWhile isSpace . drop (length pkgDbKey)
-
-
+    extractValue = takeWhile (`notElem` "\n\r") . dropWhile isSpace . drop (length pkgDbKey)
+
 -- | looks for file matching a predicate starting from dir and going up until root
 findFile :: (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath)
 findFile p dir = do

diff --git a/src/Client.hs b/src/Client.hs
@@ -8,7 +8,7 @@ import Control.Exception (tryJust)
 import Control.Monad (guard)
 import Network (PortID(UnixSocket), connectTo)
 import System.Exit (exitFailure, exitWith)
-import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr)
+import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, hPrint, stderr)
 import System.IO.Error (isDoesNotExistError)
 
 import Daemonize (daemonize)
@@ -17,20 +17,20 @@ import Types (ClientDirective(..), Command(..), CommandExtra(..), ServerDirectiv
 import Util (readMaybe)
 
 connect :: FilePath -> IO Handle
-connect sock = do
+connect sock = 
   connectTo "" (UnixSocket sock)
 
 getServerStatus :: FilePath -> IO ()
 getServerStatus sock = do
     h <- connect sock
-    hPutStrLn h $ show SrvStatus
+    hPrint h SrvStatus
     hFlush h
     startClientReadLoop h
 
 stopServer :: FilePath -> IO ()
 stopServer sock = do
     h <- connect sock
-    hPutStrLn h $ show SrvExit
+    hPrint h SrvExit
     hFlush h
     startClientReadLoop h
 
@@ -39,7 +39,7 @@ serverCommand sock cmd cmdExtra = do
     r <- tryJust (guard . isDoesNotExistError) (connect sock)
     case r of
         Right h -> do
-            hPutStrLn h $ show (SrvCommand cmd cmdExtra)
+            hPrint h (SrvCommand cmd cmdExtra)
             hFlush h
             startClientReadLoop h
         Left _ -> do

diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs
@@ -261,20 +261,20 @@ full progName = modes_ [admin += auto, check, moduleFile, info, type_, findSymbo
 
 
 fileArg :: HDevTools -> Maybe String
-fileArg (Admin {})      = Nothing
-fileArg (ModuleFile {}) = Nothing
-fileArg a@(Check {}) = Just $ file a
-fileArg a@(Info  {}) = Just $ file a
-fileArg a@(Type  {}) = Just $ file a
-fileArg (FindSymbol {}) = Nothing
+fileArg Admin {}      = Nothing
+fileArg ModuleFile {} = Nothing
+fileArg a@Check {} = Just $ file a
+fileArg a@Info  {} = Just $ file a
+fileArg a@Type  {} = Just $ file a
+fileArg FindSymbol {} = Nothing
 
 pathArg' :: HDevTools -> Maybe String
-pathArg' (Admin {})      = Nothing
-pathArg' (ModuleFile {}) = Nothing
-pathArg' a@(Check {}) = path a
-pathArg' a@(Info  {}) = path a
-pathArg' a@(Type  {}) = path a
-pathArg' (FindSymbol {}) = Nothing
+pathArg' Admin {}      = Nothing
+pathArg' ModuleFile {} = Nothing
+pathArg' a@Check {} = path a
+pathArg' a@Info  {} = path a
+pathArg' a@Type  {} = path a
+pathArg' FindSymbol {} = Nothing
 
 pathArg :: HDevTools -> Maybe String
 pathArg a = case pathArg' a of

diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs
@@ -48,7 +48,7 @@ data State = State
     }
 
 newCommandLoopState :: IO (IORef State)
-newCommandLoopState = do
+newCommandLoopState = 
     newIORef $ State
         { stateWarningsEnabled = True
         }
@@ -81,7 +81,7 @@ updateConfig mConfig cmdExtra = do
     mbCabalConfig <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmdExtra)) $
       ceCabalFilePath cmdExtra
 
-    mbStackConfig <- if (stackYaml <$> msc) == (ceStackYamlPath cmdExtra)
+    mbStackConfig <- if (stackYaml <$> msc) == ceStackYamlPath cmdExtra
       then return msc
       else getStackConfig cmdExtra
 
@@ -97,13 +97,12 @@ type CommandObj = (Command, Config)
 
 withWarnings :: (MonadIO m, Exception.ExceptionMonad m) => IORef State -> Bool -> m a -> m a
 withWarnings state warningsValue action = do
-    beforeState <- liftIO $ getWarnings
+    beforeState <- liftIO getWarnings
     liftIO $ setWarnings warningsValue
-    action `GHC.gfinally`
-        (liftIO $ setWarnings beforeState)
+    action `GHC.gfinally` liftIO (setWarnings beforeState)
     where
     getWarnings :: IO Bool
-    getWarnings = readIORef state >>= return . stateWarningsEnabled
+    getWarnings = stateWarningsEnabled <$> readIORef state
     setWarnings :: Bool -> IO ()
     setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val }
 
@@ -146,7 +145,7 @@ startCommandLoop state clientSend getNextCommand initialConfig mbInitialCommand
                         processNextCommand False
 
     sendErrors :: GHC.Ghc () -> GHC.Ghc ()
-    sendErrors action = do
+    sendErrors action = 
             action `GHC.gcatch` ghcError
                    `GHC.gcatch` sourceError
                    `GHC.gcatch` unknownError
@@ -210,10 +209,10 @@ configSession state clientSend config = do
 loadTarget :: [FilePath] -> Config -> GHC.Ghc (Maybe GHC.SuccessFlag)
 loadTarget files conf = do
     let noPhase = Nothing
-    targets <- mapM (flip GHC.guessTarget noPhase) files
+    targets <- mapM (`GHC.guessTarget` noPhase) files
     GHC.setTargets targets
     graph <- GHC.depanal [] True
-    if configTH conf || (not $ needsTemplateHaskellOrQQ graph)
+    if configTH conf || not (needsTemplateHaskellOrQQ graph)
         then do
             when (needsTemplateHaskellOrQQ graph) $ do
                 flags <- GHC.getSessionDynFlags

diff --git a/src/Info.hs b/src/Info.hs
@@ -42,7 +42,7 @@ getIdentifierInfo file identifier =
         GHC.setContext [GHC.ms_mod m] []
 #endif
         GHC.handleSourceError (return . Left . show) $
-            liftM Right (infoThing identifier)
+            fmap Right (infoThing identifier)
 
 getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)])
 getType file (line, col) =
@@ -62,7 +62,7 @@ withModSummary file action = do
 getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary)
 getModuleSummary file = do
     modSummaries <- getModSummaries
-    case find (moduleSummaryMatchesFilePath file) $ modSummaries of
+    case find (moduleSummaryMatchesFilePath file) modSummaries of
         Nothing -> return Nothing
         Just moduleSummary -> return (Just moduleSummary)
 
@@ -123,9 +123,11 @@ getSrcSpan (GHC.RealSrcSpan spn) =
          , GHC.srcSpanEndCol spn)
 getSrcSpan _ = Nothing
 
-getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind TypecheckI -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))
+getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind TypecheckI
+    -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))
 #if __GLASGOW_HASKELL__ >= 708
-getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty grp)
+getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) =
+    return $ Just (spn, HsExpr.mg_res_ty $ HsExpr.mg_ext grp)
 #else
 getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ)
 #endif
@@ -208,10 +210,20 @@ data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
 --   generated the Ast.
 everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
 everythingStaged stage k z f x
-  | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
+#if __GLASGOW_HASKELL__ >= 860
+-- This is a hack, ghc 8.6 changed representation from PostTc
+-- to a whole bunch of individial types and I don't really want
+-- to handle all of them, at least for the moment since I'm not using
+-- this functionality
+  | (const False `extQ` fixity `extQ` nameSet) x = z
+#else
+  | (const False `extQ` {- postTcType `extQ` -} fixity `extQ` nameSet) x = z
+#endif
   | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
   where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool
-#if __GLASGOW_HASKELL__ >= 709
+#if __GLASGOW_HASKELL__ >= 806
+        -- there's no more "simple" PostTc type in ghc 8.6
+#elif __GLASGOW_HASKELL__ >= 709
         postTcType = const (stage<TypeChecker)                 :: GHC.PostTc TypecheckI GHC.Type -> Bool
 #else
         postTcType = const (stage<TypeChecker)                 :: GHC.PostTcType -> Bool
@@ -287,3 +299,4 @@ pprInfo pefas (thing, fixity, insts) =
     show_fixity fix
         | fix == GHC.defaultFixity = Outputable.empty
         | otherwise                = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing)
+
diff --git a/src/Server.hs b/src/Server.hs
@@ -1,13 +1,13 @@
 module Server where
 
 import Control.Exception (bracket, finally, handleJust, tryJust)
-import Control.Monad (guard)
+import Control.Monad (guard, forM_)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import GHC.IO.Exception (IOErrorType(ResourceVanished))
 import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose)
 import System.Directory (removeFile)
 import System.Exit (ExitCode(ExitSuccess))
-import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn)
+import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, hPrint)
 import System.IO.Error (ioeGetErrorType, isAlreadyInUseError, isDoesNotExistError)
 
 import CommandLoop (newCommandLoopState, Config, updateConfig, startCommandLoop)
@@ -24,10 +24,10 @@ createListenSocket socketPath = do
             listenOn (UnixSocket socketPath)
 
 startServer :: FilePath -> Maybe Socket -> CommandExtra -> IO ()
-startServer socketPath mbSock cmdExtra = do
+startServer socketPath mbSock cmdExtra = 
     case mbSock of
         Nothing -> bracket (createListenSocket socketPath) cleanup go
-        Just sock -> (go sock) `finally` (cleanup sock)
+        Just sock -> go sock `finally` cleanup sock
     where
     cleanup :: Socket -> IO ()
     cleanup sock = do
@@ -53,7 +53,7 @@ clientSend currentClient clientDirective = do
     mbH <- readIORef currentClient
     case mbH of
         Just h -> ignoreEPipe $ do
-            hPutStrLn h (show clientDirective)
+            hPrint h clientDirective
             hFlush h
         Nothing -> return ()
     where
@@ -64,9 +64,7 @@ clientSend currentClient clientDirective = do
 getNextCommand :: IORef (Maybe Handle) -> Socket -> IORef (Maybe Config) -> IO (Maybe (Command, Config))
 getNextCommand currentClient sock config = do
     checkCurrent <- readIORef currentClient
-    case checkCurrent of
-        Just h -> hClose h
-        Nothing -> return ()
+    forM_ checkCurrent hClose
     (h, _, _) <- accept sock
     writeIORef currentClient (Just h)
     msg <- hGetLine h -- TODO catch exception
@@ -82,13 +80,13 @@ getNextCommand currentClient sock config = do
             writeIORef config (Just config')
             return $ Just (cmd, config')
         Just SrvStatus -> do
-            mapM_ (clientSend currentClient) $
+            mapM_ (clientSend currentClient)
                 [ ClientStdout "Server is running."
                 , ClientExit ExitSuccess
                 ]
             getNextCommand currentClient sock config
         Just SrvExit -> do
-            mapM_ (clientSend currentClient) $
+            mapM_ (clientSend currentClient)
                 [ ClientStdout "Shutting down server."
                 , ClientExit ExitSuccess
                 ]

diff --git a/src/Stack.hs b/src/Stack.hs
@@ -64,7 +64,7 @@ getStackDist p = (trim <$>) <$> execStackInPath "path --dist-dir" p
 getStackDbs :: FilePath -> IO (Maybe [FilePath])
 getStackDbs p =
   execStackInPath "path --ghc-package-path" p >>=
-  maybe (return Nothing) (\pp -> return <$> extractDbs pp)
+  maybe (return Nothing) (fmap return . extractDbs)
 
 extractDbs :: String -> IO [FilePath]
 extractDbs = filterM doesDirectoryExist . stringPaths