diff --git a/hsdev.cabal b/hsdev.cabal --- a/hsdev.cabal +++ b/hsdev.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hsdev -version: 0.1.7.3 +version: 0.1.8.0 synopsis: Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc. description: Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc. @@ -43,9 +43,11 @@ HsDev.Database.Update HsDev.Database.Update.Types HsDev.Display + HsDev.Error HsDev.Inspect HsDev.PackageDb HsDev.Project + HsDev.Project.Types HsDev.Scan HsDev.Scan.Browse HsDev.Server.Base @@ -75,6 +77,7 @@ HsDev.Tools.HDocs HsDev.Tools.HLint HsDev.Tools.Types + HsDev.Types HsDev.Util HsDev.Version HsDev.Watcher @@ -182,6 +185,7 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, + data-default >= 0.5.0, directory >= 1.2.0, filepath >= 1.4.0, mtl >= 2.2.0, @@ -203,6 +207,7 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, + data-default >= 0.5.0, directory >= 1.2.0, ghc >= 7.10.0 && < 7.11.0, haskell-src-exts >= 1.17.0 && < 1.18.0, @@ -226,6 +231,7 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, + data-default >= 0.5.0, mtl >= 2.2.0, optparse-applicative >= 0.11, text >= 1.2.0, @@ -245,6 +251,7 @@ aeson-pretty >= 0.7.0, bytestring >= 0.10.0, containers >= 0.5.0, + data-default >= 0.5.0, mtl >= 2.2.0, optparse-applicative >= 0.11, text >= 1.2.0, @@ -263,6 +270,7 @@ aeson >= 0.7.0, aeson-pretty >= 0.7.0, bytestring >= 0.10.0, + data-default >= 0.5.0, directory >= 1.2.0, lens >= 4.8, mtl >= 2.2.0, diff --git a/src/HsDev.hs b/src/HsDev.hs --- a/src/HsDev.hs +++ b/src/HsDev.hs @@ -1,6 +1,8 @@ module HsDev ( module Data.Default, + module HsDev.Types, + module HsDev.Error, module HsDev.Server.Base, module HsDev.Server.Commands, module HsDev.Client.Commands, @@ -16,6 +18,8 @@ import Data.Default +import HsDev.Types +import HsDev.Error import HsDev.Server.Base import HsDev.Server.Commands import HsDev.Client.Commands diff --git a/src/HsDev/Client/Commands.hs b/src/HsDev/Client/Commands.hs --- a/src/HsDev/Client/Commands.hs +++ b/src/HsDev/Client/Commands.hs @@ -5,7 +5,6 @@ ) where import Control.Applicative -import Control.Arrow import Control.Concurrent.MVar import Control.Exception (displayException) import Control.Lens (view, preview, _Just) @@ -13,7 +12,8 @@ import Control.Monad.Except import Control.Monad.Reader import qualified Control.Monad.State as State -import Control.Monad.Catch (try, SomeException(..)) +import Control.Monad.Catch (try, catch, SomeException(..)) +import Control.Monad.CatchIO (bracket) import Data.Aeson hiding (Result, Error) import Data.List import Data.Foldable (toList) @@ -22,7 +22,6 @@ import Data.String (fromString) import Data.Text (unpack) import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf) -import Data.Text.Lens (packed) import System.Directory import System.FilePath import qualified System.Log.Simple as Log @@ -34,6 +33,7 @@ import Text.Format import HsDev.Cache import HsDev.Commands +import HsDev.Error import qualified HsDev.Database.Async as DB import HsDev.Server.Message as M import HsDev.Server.Types @@ -59,11 +59,8 @@ runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result runClient copts = mapServerM toResult . runClientM where - toResult :: (ToJSON a, ServerMonadBase m) => ExceptT CommandError (ReaderT CommandOptions m) a -> m Result - toResult act = liftM asResult $ runReaderT (runExceptT act) copts - asResult :: ToJSON a => Either CommandError a -> Result - asResult (Left (CommandError e ds)) = Error e $ M.fromList $ map (first unpack) ds - asResult (Right r') = Result $ toJSON r' + toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result + toResult act = liftM (either Error (Result . toJSON)) $ runReaderT (try act) copts mapServerM :: (Monad m, Monad n) => (m a -> n b) -> ServerM m a -> ServerM n b mapServerM f = ServerM . mapReaderT f . runServerM @@ -72,8 +69,13 @@ runCommand :: ServerMonadBase m => Command -> ClientM m Value runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)] -runCommand Listen = toValue $ do +runCommand (Listen (Just r)) = bracket (serverSetLogRules ["/: {}" ~~ r]) serverSetLogRules $ \_ -> runCommand (Listen Nothing) +runCommand (Listen Nothing) = toValue $ do serverListen >>= mapM_ (\msg -> commandNotify (Notification $ object ["message" .= msg])) +runCommand (SetLogConfig rs) = toValue $ do + rules' <- serverSetLogRules rs + Log.log Log.Debug $ "log rules switched from '{}' to '{}'" ~~ intercalate ", " rules' ~~ intercalate ", " rs + Log.log Log.Info $ "log rules updated to: {}" ~~ intercalate ", " rs runCommand (AddData cts) = toValue $ mapM_ updateData cts where updateData (AddedDatabase db) = toValue $ serverUpdateDB db updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m @@ -116,11 +118,11 @@ forM_ projects $ \proj -> do DB.clear db (return $ projectDB proj dbval) liftIO $ unwatchProject w proj - dbPDbs <- liftIO $ mapM restorePackageDbStack $ databasePackageDbs dbval + dbPDbs <- mapM restorePackageDbStack $ databasePackageDbs dbval flip State.evalStateT dbPDbs $ do when cabal $ removePackageDbStack userDb forM_ sboxes' $ \sbox -> do - pdbs <- lift $ mapCommandIO $ sandboxPackageDbStack sbox + pdbs <- lift $ sandboxPackageDbStack sbox removePackageDbStack pdbs forM_ files $ \file -> do DB.clear db (return $ filterDB (inFile file) (const False) dbval) @@ -174,121 +176,102 @@ getScope | exports = exportsModule | otherwise = scopeModule - case lookupFile fpath dbval of - Nothing -> commandError "File not found" [] - Just m -> return $ getScope $ resolveOne dbval m + m <- refineSourceModule fpath + return $ getScope $ resolveOne dbval m runCommand (InfoProject (Left projName)) = toValue $ findProject projName runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject projPath runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandbox sandbox' runCommand (Lookup nm fpath) = toValue $ do dbval <- getSDb fpath - mapCommandIO $ lookupSymbol dbval fpath nm + liftIO $ hsdevLift $ lookupSymbol dbval fpath nm runCommand (Whois nm fpath) = toValue $ do dbval <- getSDb fpath - mapCommandIO $ whois dbval fpath nm + liftIO $ hsdevLift $ whois dbval fpath nm runCommand (ResolveScopeModules sq fpath) = toValue $ do dbval <- getSDb fpath - liftM (filterMatch sq . map (view moduleId)) $ mapCommandIO $ scopeModules dbval fpath + liftM (filterMatch sq . map (view moduleId)) $ liftIO $ hsdevLift $ scopeModules dbval fpath runCommand (ResolveScope sq global fpath) = toValue $ do dbval <- getSDb fpath - liftM (filterMatch sq) $ mapCommandIO $ scope dbval fpath global + liftM (filterMatch sq) $ liftIO $ hsdevLift $ scope dbval fpath global runCommand (Complete input wide fpath) = toValue $ do dbval <- getSDb fpath - mapCommandIO $ completions dbval fpath input wide + liftIO $ hsdevLift $ completions dbval fpath input wide runCommand (Hayoo hq p ps) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM (mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $ - mapCommandIO $ Hayoo.hayoo hq (Just i) -runCommand (CabalList packages) = toValue $ mapCommandIO $ Cabal.cabalList packages + liftIO $ hsdevLift $ Hayoo.hayoo hq (Just i) +runCommand (CabalList packages) = toValue $ liftIO $ hsdevLift $ Cabal.cabalList packages runCommand (Lint fs fcts) = toValue $ do - mapCommandIO $ liftM2 (++) + liftIO $ hsdevLift $ liftM2 (++) (liftM concat $ mapM HLint.hlintFile fs) (liftM concat $ mapM (\(FileContents f c) -> HLint.hlintSource f c) fcts) runCommand (Check fs fcts ghcs') = toValue $ Log.scope "check" $ do - dbval <- getDb ghc <- askSession sessionGhc liftIO $ restartWorker ghc let checkSome file fn = Log.scope "checkSome" $ do - pdbs <- liftIO $ searchPackageDbStack file - m <- maybe - (commandError_ $ "File '{}' not found" ~~ file) - return - (lookupFile file dbval) - notes <- inWorkerWith (commandError_ . show) ghc - (runExceptT $ fn pdbs m) - either commandError_ return notes + pdbs <- searchPackageDbStack file + m <- refineSourceModule file + inWorkerWith (hsdevError . GhcError . displayException) ghc (fn pdbs m) liftM concat $ mapM (uncurry checkSome) $ [(f, Check.checkFile ghcs') | f <- fs] ++ [(f, \pdbs m -> Check.checkSource ghcs' pdbs m src) | FileContents f src <- fcts] runCommand (CheckLint fs fcts ghcs') = toValue $ do - dbval <- getDb ghc <- askSession sessionGhc liftIO $ restartWorker ghc let checkSome file fn = do - pdbs <- liftIO $ searchPackageDbStack file - m <- maybe - (commandError_ $ "File '" ++ file ++ "' not found") - return - (lookupFile file dbval) - notes <- inWorkerWith (commandError_ . show) ghc - (runExceptT $ fn pdbs m) - either commandError_ return notes + pdbs <- searchPackageDbStack file + m <- refineSourceModule file + inWorkerWith (hsdevError . GhcError . displayException) ghc (fn pdbs m) checkMsgs <- liftM concat $ mapM (uncurry checkSome) $ [(f, Check.checkFile ghcs') | f <- fs] ++ [(f, \pdbs m -> Check.checkSource ghcs' pdbs m src) | FileContents f src <- fcts] - lintMsgs <- mapCommandIO $ liftM2 (++) + lintMsgs <- liftIO $ hsdevLift $ liftM2 (++) (liftM concat $ mapM HLint.hlintFile fs) (liftM concat $ mapM (\(FileContents f src) -> HLint.hlintSource f src) fcts) return $ checkMsgs ++ lintMsgs runCommand (Types fs fcts ghcs') = toValue $ do - dbval <- getDb ghc <- askSession sessionGhc let cts = [(f, Nothing) | f <- fs] ++ [(f, Just src) | FileContents f src <- fcts] liftM concat $ forM cts $ \(file, msrc) -> do - pdbs <- liftIO $ searchPackageDbStack file - m <- maybe - (commandError_ $ "File '" ++ file ++ "' not found") - return - (lookupFile file dbval) - notes <- inWorkerWith (commandError_ . show) ghc - (runExceptT $ Types.fileTypes ghcs' pdbs m msrc) - either commandError_ return notes -runCommand (GhcMod GhcModLang) = toValue $ mapCommandIO GhcMod.langs -runCommand (GhcMod GhcModFlags) = toValue $ mapCommandIO GhcMod.flags + pdbs <- searchPackageDbStack file + m <- refineSourceModule file + inWorkerWith (hsdevError . GhcError . displayException) ghc (Types.fileTypes ghcs' pdbs m msrc) +runCommand (GhcMod GhcModLang) = toValue $ liftIO $ hsdevLift GhcMod.langs +runCommand (GhcMod GhcModFlags) = toValue $ liftIO $ hsdevLift GhcMod.flags runCommand (GhcMod (GhcModType (Position line column) fpath ghcs')) = toValue $ do ghcmod <- askSession sessionGhcMod dbval <- getDb - pdbs <- liftIO $ searchPackageDbStack fpath - pkgs <- mapCommandIO $ Scan.browsePackages ghcs' pdbs - (fpath', m', _) <- mapCommandIO $ fileCtx dbval fpath - mapCommandIO $ GhcMod.waitMultiGhcMod ghcmod fpath' $ + pdbs <- searchPackageDbStack fpath + pkgs <- Scan.browsePackages ghcs' pdbs + (fpath', m', _) <- liftIO $ hsdevLift $ fileCtx dbval fpath + liftIO $ GhcMod.waitMultiGhcMod ghcmod fpath' $ GhcMod.typeOf (ghcs' ++ moduleOpts pkgs m') pdbs fpath' line column runCommand (GhcMod (GhcModLint fs hlints')) = toValue $ do ghcmod <- askSession sessionGhcMod - mapCommandIO $ liftM concat $ forM fs $ \file -> + liftIO $ liftM concat $ forM fs $ \file -> GhcMod.waitMultiGhcMod ghcmod file $ GhcMod.lint hlints' file runCommand (GhcMod (GhcModCheck fs ghcs')) = toValue $ do ghcmod <- askSession sessionGhcMod dbval <- getDb - mapCommandIO $ liftM concat $ forM fs $ \file -> do + liftM concat $ forM fs $ \file -> do mproj <- liftIO $ locateProject file - pdbs <- liftIO $ searchPackageDbStack file + pdbs <- searchPackageDbStack file pkgs <- Scan.browsePackages ghcs' pdbs - (_, m', _) <- fileCtx dbval file - GhcMod.waitMultiGhcMod ghcmod file $ + (_, m', _) <- liftIO $ hsdevLift $ fileCtx dbval file + liftIO $ GhcMod.waitMultiGhcMod ghcmod file $ GhcMod.check (ghcs' ++ moduleOpts pkgs m') pdbs [file] mproj runCommand (GhcMod (GhcModCheckLint fs ghcs' hlints')) = toValue $ do ghcmod <- askSession sessionGhcMod dbval <- getDb - mapCommandIO $ liftM concat $ forM fs $ \file -> do + liftM concat $ forM fs $ \file -> do mproj <- liftIO $ locateProject file - pdbs <- liftIO $ searchPackageDbStack file + pdbs <- searchPackageDbStack file pkgs <- Scan.browsePackages ghcs' pdbs - (_, m', _) <- fileCtx dbval file - GhcMod.waitMultiGhcMod ghcmod file $ do + (_, m', _) <- liftIO $ hsdevLift $ fileCtx dbval file + liftIO $ GhcMod.waitMultiGhcMod ghcmod file $ do checked <- GhcMod.check (ghcs' ++ moduleOpts pkgs m') pdbs [file] mproj linted <- GhcMod.lint hlints' file return $ checked ++ linted @@ -308,10 +291,10 @@ runFix file | isPure = return $ fst $ doFix file "" | otherwise = do - (corrs', cts') <- liftM (doFix file) $ liftE $ readFileUtf8 file - liftE $ writeFileUtf8 file cts' + (corrs', cts') <- liftM (doFix file) $ liftIO $ readFileUtf8 file + liftIO $ writeFileUtf8 file cts' return corrs' - mapCommandIO $ liftM concat $ mapM runFix files + liftM concat $ mapM runFix files runCommand (GhcEval exprs) = toValue $ do ghci <- askSession sessionGhci async' <- liftIO $ pushTask ghci $ mapM (try . evaluate) exprs @@ -319,7 +302,7 @@ return $ map toValue' res where waitAsync :: CommandMonad m => Async a -> m a - waitAsync a = liftIO (waitCatch a) >>= either (commandError_ . displayException) return + waitAsync a = liftIO (waitCatch a) >>= either (hsdevError . GhcError . displayException) return toValue' :: ToJSON a => Either SomeException a -> Value toValue' (Left (SomeException e)) = object ["fail" .= show e] toValue' (Right s) = toJSON s @@ -339,7 +322,7 @@ TargetDepsOf dep -> liftM inDeps $ findDep dep TargetPackageDb pdb -> return $ inPackageDb pdb TargetCabal -> return $ inPackageDbStack userDb - TargetSandbox sbox -> liftM inPackageDbStack $ findSandbox sbox >>= mapCommandIO . sandboxPackageDbStack + TargetSandbox sbox -> liftM inPackageDbStack $ findSandbox sbox >>= sandboxPackageDbStack TargetPackage pack -> return $ inPackage pack TargetSourced -> return byFile TargetStandalone -> return standalone @@ -359,11 +342,14 @@ findSandbox fpath = do fpath' <- findPath fpath sbox <- liftIO $ S.findSandbox fpath' - maybe - (commandError ("Sandbox {} not found" ~~ fpath') ["sandbox" .= fpath']) - return - sbox + maybe (hsdevError $ FileNotFound fpath') return sbox +-- | Get module by source +refineSourceModule :: (CommandMonad m, Functor m) => FilePath -> m Module +refineSourceModule fpath = do + db' <- getDb + maybe (hsdevError (NotInspected $ FileModule fpath Nothing)) return $ lookupFile fpath db' + -- | Get list of enumerated sandboxes getSandboxes :: (CommandMonad m, Functor m) => [FilePath] -> m [Sandbox] getSandboxes = traverse (findPath >=> findSandbox) @@ -377,7 +363,7 @@ resultProj = refineProject db' (project proj') <|> find ((== proj) . view projectName) (databaseProjects db') - maybe (commandError_ $ "Project {} not found" ~~ proj) return resultProj + maybe (hsdevError $ ProjectNotFound proj) return resultProj where addCabal p | takeExtension p == ".cabal" = p @@ -390,15 +376,14 @@ proj <- msum [ do p <- liftIO (locateProject depPath) - p' <- maybe (commandError_ $ "Project {} not found" ~~ depName) return p - r <- liftIO $ runExceptT $ loadProject p' - either commandError_ return r, + p' <- maybe (hsdevError $ ProjectNotFound depName) return p + liftIO $ loadProject p', findProject depName] let src | takeExtension depPath == ".hs" = Just depPath | otherwise = Nothing - pdbs <- liftIO $ searchPackageDbStack $ view projectPath proj + pdbs <- searchPackageDbStack $ view projectPath proj return (proj, src, pdbs) -- FIXME: Doesn't work for file without project @@ -422,15 +407,14 @@ getSDb :: SessionMonad m => FilePath -> m Database getSDb fpath = do dbval <- getDb - pdbs <- liftIO $ searchPackageDbStack fpath + pdbs <- searchPackageDbStack fpath return $ filterDB (restrictPackageDbStack pdbs) (const True) dbval -mapCommandIO :: CommandMonad m => ExceptT String IO a -> m a -mapCommandIO act = liftIO (runExceptT act) >>= either commandError_ return - -- | Run DB update action updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m () -updateProcess uopts acts = Update.runUpdate uopts $ sequence_ [act `catchError` (Log.log Log.Error . view (commandErrorMsg . packed)) | act <- acts] +updateProcess uopts acts = Update.runUpdate uopts $ mapM_ runAct acts where + runAct act = catch act onError + onError e = Log.log Log.Error $ "{}" ~~ (e :: HsDevError) -- | Filter declarations with prefix and infix filterMatch :: Symbol a => SearchQuery -> [a] -> [a] diff --git a/src/HsDev/Database/Update.hs b/src/HsDev/Database/Update.hs --- a/src/HsDev/Database/Update.hs +++ b/src/HsDev/Database/Update.hs @@ -18,9 +18,6 @@ scan, updateEvent, processEvent, - -- * Helpers - liftExceptT, liftExceptT_, - module HsDev.Watcher, module Control.Monad.Except @@ -31,6 +28,7 @@ import Control.Concurrent.Lifted (fork) import Control.DeepSeq import Control.Lens (preview, _Just, view, over, set, _1, mapMOf_, each, (^..), _head, _Right) +import Control.Monad.Catch (catch) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Writer @@ -45,6 +43,7 @@ import qualified System.Log.Simple as Log import Control.Concurrent.Worker (inWorker, restartWorker) +import HsDev.Error import qualified HsDev.Cache.Structured as Cache import HsDev.Database import HsDev.Database.Async hiding (Event) @@ -54,13 +53,13 @@ import HsDev.Sandbox import HsDev.Stack import HsDev.Symbols -import HsDev.Tools.Ghc.Worker (setCmdOpts) +import HsDev.Tools.Ghc.Worker (setCmdOpts, liftGhc) import HsDev.Tools.Ghc.Types (inferTypes) import HsDev.Tools.HDocs import qualified HsDev.Scan as S import HsDev.Scan.Browse -import HsDev.Util (liftE, isParent, ordNub) -import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache, CommandError(..), commandError_) +import HsDev.Util (isParent, ordNub) +import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache) import HsDev.Server.Message import HsDev.Database.Update.Types import HsDev.Watcher @@ -111,27 +110,18 @@ return r scanDocs_ :: UpdateMonad m => InspectedModule -> m () scanDocs_ im = do - im' <- - liftExceptT - ("Scanning docs for {} failed: {}" ~~ view inspectedId im) - (S.scanModify (\opts _ -> inspectDocs opts) im) - <|> return im + im' <- (S.scanModify (\opts _ -> liftIO . inspectDocs opts) im) <|> return im updater $ return $ fromModule im' inferModTypes_ :: UpdateMonad m => InspectedModule -> m () inferModTypes_ im = do -- TODO: locate sandbox s <- getSession - im' <- - liftExceptT - ("Inferring types for {} failed: {}" ~~ view inspectedId im) - (S.scanModify (infer' s) im) - <|> return im + im' <- (S.scanModify (infer' s) im) <|> return im updater $ return $ fromModule im' - infer' :: Session -> [String] -> PackageDbStack -> Module -> ExceptT String IO Module + infer' :: UpdateMonad m => Session -> [String] -> PackageDbStack -> Module -> m Module infer' s opts pdbs m = case preview (moduleLocation . moduleFile) m of Nothing -> return m - Just _ -> inWorkerT (sessionGhc s) $ inferTypes opts pdbs m Nothing - inWorkerT w = ExceptT . inWorker w . runExceptT + Just _ -> liftIO $ inWorker (sessionGhc s) $ inferTypes opts pdbs m Nothing -- | Post status postStatus :: UpdateMonad m => Task -> m () @@ -184,8 +174,8 @@ x <- childTask task act x `deepseq` postStatus (set taskStatus StatusOk task) return x - `catchError` - (\c@(CommandError e _) -> postStatus (set taskStatus (StatusError e) task) >> throwError c) + `catch` + (\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e) where task = Task { _taskName = action, @@ -210,7 +200,7 @@ scanModule :: UpdateMonad m => [String] -> ModuleLocation -> Maybe String -> m () scanModule opts mloc mcts = runTask "scanning" mloc $ Log.scope "module" $ do defs <- askSession sessionDefines - im <- liftExceptT_ $ S.scanModule defs opts mloc mcts + im <- S.scanModule defs opts mloc mcts updater $ return $ fromModule im _ <- return $ view inspectionResult im return () @@ -231,16 +221,16 @@ -- | Scan source file with contents scanFileContents :: UpdateMonad m => [String] -> FilePath -> Maybe String -> m () -scanFileContents opts fpath mcts = Log.scope "file" $ do +scanFileContents opts fpath mcts = Log.scope "file" $ hsdevLiftIO $ do dbval <- readDB - fpath' <- liftCIO $ canonicalizePath fpath - ex <- liftCIO $ doesFileExist fpath' + fpath' <- liftIO $ canonicalizePath fpath + ex <- liftIO $ doesFileExist fpath' mlocs <- if ex then do mloc <- case lookupFile fpath' dbval of Just m -> return $ view moduleLocation m Nothing -> do - mproj <- liftCIO $ locateProject fpath' + mproj <- liftIO $ locateProject fpath' return $ FileModule fpath' mproj return [(mloc, [], mcts)] else return [] @@ -268,8 +258,8 @@ -- | Prepare sandbox for scanning. This is used for stack project to build & configure. prepareSandbox :: UpdateMonad m => Sandbox -> m () prepareSandbox sbox@(Sandbox StackWork fpath) = Log.scope "prepare" $ runTasks [ - runTask "building dependencies" sbox $ void $ liftIO $ runMaybeT $ buildDeps myaml, - runTask "configuring" sbox $ void $ liftIO $ runMaybeT $ configure myaml] + runTask "building dependencies" sbox $ void $ buildDeps myaml, + runTask "configuring" sbox $ void $ configure myaml] where myaml = Just $ takeDirectory fpath "stack.yaml" prepareSandbox _ = return () @@ -279,7 +269,7 @@ scanSandbox opts sbox = Log.scope "sandbox" $ do dbval <- readDB prepareSandbox sbox - pdbs <- liftExceptT_ $ sandboxPackageDbStack sbox + pdbs <- sandboxPackageDbStack sbox let scannedDbs = databasePackageDbs dbval unscannedDbs = filter ((`notElem` scannedDbs) . topPackageDb) $ reverse $ packageDbStacks pdbs @@ -293,10 +283,10 @@ watch (\w -> watchPackageDb w pdbs opts) mlocs <- liftM (filter (\mloc -> preview modulePackageDb mloc == Just (topPackageDb pdbs))) $ - liftExceptT_ $ listModules opts pdbs + listModules opts pdbs scan (Cache.loadPackageDb (topPackageDb pdbs)) (packageDbDB (topPackageDb pdbs)) ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do - ms <- liftExceptT_ $ browseModules opts pdbs (mlocs' ^.. each . _1) - docs <- liftExceptT_ $ hdocsCabal pdbs opts + ms <- browseModules opts pdbs (mlocs' ^.. each . _1) + docs <- liftIO $ hsdevLiftWith (ToolError "hdocs") $ hdocsCabal pdbs opts updater $ return $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms where setDocs' :: Map String (Map String String) -> Module -> Module @@ -304,7 +294,7 @@ -- | Scan project file scanProjectFile :: UpdateMonad m => [String] -> FilePath -> m Project -scanProjectFile opts cabal = runTask "scanning" cabal $ liftExceptT_ $ S.scanProjectFile opts cabal +scanProjectFile opts cabal = runTask "scanning" cabal $ S.scanProjectFile opts cabal -- | Scan project and related package-db stack scanProjectStack :: UpdateMonad m => [String] -> FilePath -> m () @@ -319,7 +309,7 @@ scanProject opts cabal = runTask "scanning" (project cabal) $ Log.scope "project" $ do proj <- scanProjectFile opts cabal watch (\w -> watchProject w proj opts) - S.ScanContents _ [(_, sources)] _ <- liftExceptT_ $ S.enumProject proj + S.ScanContents _ [(_, sources)] _ <- S.enumProject proj scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ \ms -> do scanModules opts ms updater $ return $ fromProject proj @@ -327,7 +317,7 @@ -- | Scan directory for source files and projects scanDirectory :: UpdateMonad m => [String] -> FilePath -> m () scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do - S.ScanContents standSrcs projSrcs pdbss <- liftExceptT_ $ S.enumDirectory dir + S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory dir runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs] runTasks $ map (scanPackageDb opts) pdbss -- TODO: Don't rescan mapMOf_ (each . _1) (watch . flip watchModule) standSrcs @@ -358,37 +348,41 @@ scanDocs ims = do -- w <- liftIO $ ghcWorker ["-haddock"] (return ()) w <- askSession sessionGhc - liftIO $ do - restartWorker w - inWorker w $ setCmdOpts ["-haddock"] - runTasks $ map (scanDocs' w) ims + liftIO $ restartWorker w + runTasks $ map scanDocs' ims where - scanDocs' w im = runTask "scanning docs" (view inspectedId im) $ Log.scope "docs" $ do - Log.log Log.Trace $ "Scanning docs for {}" ~~ view inspectedId im - im' <- - liftExceptT - ("Scanning docs for {} failed: {}" ~~ view inspectedId im) - (S.scanModify (\opts _ -> inWorkerT w . inspectDocsGhc opts) im) - <|> return im - Log.log Log.Trace $ "Docs for {} updated: documented {} declarations" ~~ - view inspectedId im' ~~ - length (im' ^.. inspectionResult . _Right . moduleDeclarations . each . declarationDocs . _Just) - updater $ return $ fromModule im' - inWorkerT w = ExceptT . inWorker w . runExceptT + scanDocs' im + | not $ hasTag RefinedDocsTag im = runTask "scanning docs" (view inspectedId im) $ Log.scope "docs" $ do + Log.log Log.Trace $ "Scanning docs for {}" ~~ view inspectedId im + im' <- (liftM (setTag RefinedDocsTag) $ S.scanModify doScan im) + <|> return im + Log.log Log.Trace $ "Docs for {} updated: documented {} declarations" ~~ + view inspectedId im' ~~ + length (im' ^.. inspectionResult . _Right . moduleDeclarations . each . declarationDocs . _Just) + updater $ return $ fromModule im' + | otherwise = Log.log Log.Trace $ "Docs for {} already scanned" ~~ view inspectedId im + doScan opts _ m = do + w <- askSession sessionGhc + pdbs <- case view moduleLocation m of + FileModule fpath _ -> searchPackageDbStack fpath + InstalledModule pdb _ _ -> restorePackageDbStack pdb + ModuleSource _ -> return userDb + pkgs <- browsePackages opts pdbs + liftIO $ inWorker w $ do + setCmdOpts ("-haddock" : (opts ++ moduleOpts pkgs m)) + liftGhc $ inspectDocsGhc (opts ++ moduleOpts pkgs m) m inferModTypes :: UpdateMonad m => [InspectedModule] -> m () inferModTypes = runTasks . map inferModTypes' where - inferModTypes' im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do - w <- askSession sessionGhc - Log.log Log.Trace $ "Inferring types for {}" ~~ view inspectedId im - im' <- - liftExceptT - ("Inferring types for {} failed: {}" ~~ view inspectedId im) - (S.scanModify (\opts cabal m -> inWorkerT w (inferTypes opts cabal m Nothing)) im) - <|> return im - Log.log Log.Trace $ "Types for {} inferred" ~~ view inspectedId im - updater $ return $ fromModule im' - inWorkerT w = ExceptT . inWorker w . runExceptT + inferModTypes' im + | not $ hasTag InferredTypesTag im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do + w <- askSession sessionGhc + Log.log Log.Trace $ "Inferring types for {}" ~~ view inspectedId im + im' <- (liftM (setTag InferredTypesTag) $ S.scanModify (\opts cabal m -> liftIO (inWorker w (inferTypes opts cabal m Nothing))) im) + <|> return im + Log.log Log.Trace $ "Types for {} inferred" ~~ view inspectedId im + updater $ return $ fromModule im' + | otherwise = Log.log Log.Trace $ "Types for {} already inferred" ~~ view inspectedId im -- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules. scan :: UpdateMonad m @@ -407,7 +401,7 @@ dbval <- getCache cache' part' let obsolete = filterDB (\m -> view moduleIdLocation m `notElem` (mlocs ^.. each . _1)) (const False) dbval - changed <- liftExceptT "Getting changed modules failed: {}" $ S.changedModules dbval opts mlocs + changed <- liftIO $ S.changedModules dbval opts mlocs cleaner $ return obsolete act changed @@ -445,18 +439,6 @@ preview (inspection . inspectionOpts) $ getInspected dbval m scanFile opts $ view eventPath e | otherwise = return () - -liftExceptT_ :: CommandMonad m => ExceptT String IO a -> m a -liftExceptT_ = liftExceptT "{}" - -liftExceptT :: CommandMonad m => Format -> ExceptT String IO a -> m a -liftExceptT msg act = liftIO (runExceptT act) >>= either onError return where - onError e = do - Log.log Log.Error $ msg ~~ e - commandError_ $ msg ~~ e - -liftCIO ::CommandMonad m => IO a -> m a -liftCIO = liftExceptT "Exception during IO action: {}" . liftE processEvent :: UpdateOptions -> Watched -> Event -> ClientM IO () processEvent uopts w e = runUpdate uopts $ updateEvent w e diff --git a/src/HsDev/Database/Update/Types.hs b/src/HsDev/Database/Update/Types.hs --- a/src/HsDev/Database/Update/Types.hs +++ b/src/HsDev/Database/Update/Types.hs @@ -10,6 +10,7 @@ import Control.Applicative import Control.Lens (makeLenses) import Control.Monad.Base +import Control.Monad.Catch import Control.Monad.CatchIO import Control.Monad.Except import Control.Monad.Reader @@ -19,22 +20,23 @@ import Data.Default import qualified System.Log.Simple as Log -import HsDev.Server.Types (ServerMonadBase, Session(..), CommandOptions(..), SessionMonad(..), askSession, CommandError, CommandMonad(..), ClientM(..)) +import HsDev.Server.Types (ServerMonadBase, Session(..), CommandOptions(..), SessionMonad(..), askSession, CommandMonad(..), ClientM(..)) import HsDev.Symbols +import HsDev.Types import HsDev.Util ((.::)) -data Status = StatusWorking | StatusOk | StatusError String +data Status = StatusWorking | StatusOk | StatusError HsDevError instance ToJSON Status where toJSON StatusWorking = toJSON ("working" :: String) toJSON StatusOk = toJSON ("ok" :: String) - toJSON (StatusError e) = toJSON $ object ["error" .= e] + toJSON (StatusError e) = toJSON e instance FromJSON Status where parseJSON v = msum $ map ($ v) [ withText "status" $ \t -> guard (t == "working") *> return StatusWorking, withText "status" $ \t -> guard (t == "ok") *> return StatusOk, - withObject "status" $ \obj -> StatusError <$> (obj .:: "error"), + liftM StatusError . parseJSON, fail "invalid status"] data Progress = Progress { @@ -88,7 +90,7 @@ type UpdateMonad m = (CommandMonad m, MonadReader UpdateOptions m, MonadWriter [ModuleLocation] m) newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateOptions (WriterT [ModuleLocation] (ClientM m)) a } - deriving (Applicative, Monad, MonadIO, MonadCatchIO, Functor, MonadReader UpdateOptions, MonadWriter [ModuleLocation]) + deriving (Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadCatchIO, Functor, MonadReader UpdateOptions, MonadWriter [ModuleLocation]) instance MonadTrans UpdateM where lift = UpdateM . lift . lift . lift @@ -101,18 +103,6 @@ instance ServerMonadBase m => CommandMonad (UpdateM m) where getOptions = UpdateM $ lift $ lift getOptions - -instance Monad m => MonadError CommandError (UpdateM m) where - throwError = UpdateM . lift . lift . throwError - catchError act handler = UpdateM $ catchError (runUpdateM act) (runUpdateM . handler) - -instance Monad m => Alternative (UpdateM m) where - empty = UpdateM empty - x <|> y = UpdateM $ runUpdateM x <|> runUpdateM y - -instance Monad m => MonadPlus (UpdateM m) where - mzero = UpdateM mzero - mplus l r = UpdateM $ runUpdateM l `mplus` runUpdateM r instance MonadBase b m => MonadBase b (UpdateM m) where liftBase = UpdateM . liftBase diff --git a/src/HsDev/Error.hs b/src/HsDev/Error.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Error.hs @@ -0,0 +1,61 @@ +module HsDev.Error ( + hsdevError, hsdevOtherError, hsdevLift, hsdevLiftWith, hsdevCatch, hsdevExcept, hsdevLiftIO, hsdevLiftIOWith, hsdevIgnore, + hsdevHandle, hsdevLog, + + module HsDev.Types + ) where + +import Prelude hiding (log) + +import Control.Exception (IOException) +import Control.Monad.Catch +import Control.Monad.Except +import Data.String (fromString) +import System.Log.Simple (MonadLog(..), log, Level) + +import HsDev.Types + +-- | Throw `HsDevError` +hsdevError :: MonadThrow m => HsDevError -> m a +hsdevError = throwM + +-- | Throw as `OtherError` +hsdevOtherError :: (Exception e, MonadThrow m) => e -> m a +hsdevOtherError = hsdevError . OtherError . displayException + +-- | Throw as `OtherError` +hsdevLift :: MonadThrow m => ExceptT String m a -> m a +hsdevLift = hsdevLiftWith OtherError + +-- | Throw as some `HsDevError` +hsdevLiftWith :: MonadThrow m => (String -> HsDevError) -> ExceptT String m a -> m a +hsdevLiftWith ctor act = runExceptT act >>= either (hsdevError . ctor) return + +hsdevCatch :: MonadCatch m => m a -> m (Either HsDevError a) +hsdevCatch = try + +hsdevExcept :: MonadCatch m => m a -> ExceptT HsDevError m a +hsdevExcept = ExceptT . hsdevCatch + +-- | Rethrow IO exceptions as `HsDevError` +hsdevLiftIO :: MonadCatch m => m a -> m a +hsdevLiftIO = hsdevLiftIOWith IOFailed + +-- | Rethrow IO exceptions +hsdevLiftIOWith :: MonadCatch m => (String -> HsDevError) -> m a -> m a +hsdevLiftIOWith ctor act = catch act onError where + onError :: MonadThrow m => IOException -> m a + onError = hsdevError . ctor . displayException + +-- | Ignore hsdev exception +hsdevIgnore :: MonadCatch m => a -> m a -> m a +hsdevIgnore v act = hsdevCatch act >>= either (const $ return v) return + +-- | Handle hsdev exception +hsdevHandle :: MonadCatch m => (HsDevError -> m a) -> m a -> m a +hsdevHandle h act = hsdevCatch act >>= either h return + +-- | Log hsdev exception and rethrow +hsdevLog :: (MonadLog m, MonadCatch m) => Level -> m a -> m a +hsdevLog lev act = hsdevCatch act >>= either logError return where + logError e = log lev (fromString $ show e) >> hsdevError e diff --git a/src/HsDev/Inspect.hs b/src/HsDev/Inspect.hs --- a/src/HsDev/Inspect.hs +++ b/src/HsDev/Inspect.hs @@ -38,8 +38,10 @@ import Data.Generics.Uniplate.Data import HDocs.Haddock +import HsDev.Error import HsDev.Symbols import HsDev.Tools.Base +import HsDev.Tools.Ghc.Worker () import HsDev.Tools.HDocs (hdocsy, hdocs, hdocsProcess) import HsDev.Util @@ -318,28 +320,28 @@ addDocs docsMap = over moduleDeclarations (map $ addDoc docsMap) -- | Extract files docs and set them to declarations -inspectDocsChunk :: [String] -> [Module] -> ExceptT String IO [Module] -inspectDocsChunk opts ms = do - docsMaps <- liftE $ hdocsy (map (view moduleLocation) ms) opts +inspectDocsChunk :: [String] -> [Module] -> IO [Module] +inspectDocsChunk opts ms = hsdevLiftIOWith (ToolError "hdocs") $ do + docsMaps <- hdocsy (map (view moduleLocation) ms) opts return $ zipWith addDocs docsMaps ms -- | Extract file docs and set them to module declarations -inspectDocs :: [String] -> Module -> ExceptT String IO Module +inspectDocs :: [String] -> Module -> IO Module inspectDocs opts m = do let hdocsWorkaround = False - docsMap <- liftE $ if hdocsWorkaround + docsMap <- hsdevLiftIOWith (ToolError "hdocs") $ if hdocsWorkaround then hdocsProcess (fromMaybe (T.unpack $ view moduleName m) (preview (moduleLocation . moduleFile) m)) opts else liftM Just $ hdocs (view moduleLocation m) opts return $ maybe id addDocs docsMap m -- | Like @inspectDocs@, but in @Ghc@ monad -inspectDocsGhc :: [String] -> Module -> ExceptT String Ghc Module +inspectDocsGhc :: [String] -> Module -> Ghc Module inspectDocsGhc opts m = case view moduleLocation m of FileModule fpath _ -> do - docsMap <- liftM (fmap (formatDocs . snd) . listToMaybe) $ readSourcesGhc opts [fpath] + docsMap <- liftM (fmap (formatDocs . snd) . listToMaybe) $ hsdevLift $ readSourcesGhc opts [fpath] return $ maybe id addDocs docsMap m - _ -> throwError "Can inspect only source file docs" + _ -> hsdevError $ ModuleNotSource (view moduleLocation m) -- | Inspect contents inspectContents :: String -> [(String, String)] -> [String] -> String -> ExceptT String IO InspectedModule @@ -354,17 +356,17 @@ contentsInspection _ _ = return InspectionNone -- crc or smth -- | Inspect file -inspectFile :: [(String, String)] -> [String] -> FilePath -> Maybe String -> ExceptT String IO InspectedModule -inspectFile defines opts file mcts = do - proj <- liftE $ locateProject file - absFilename <- liftE $ Dir.canonicalizePath file - ex <- liftE $ Dir.doesFileExist absFilename - unless ex $ throwError $ "File '" ++ absFilename ++ "' doesn't exist" +inspectFile :: [(String, String)] -> [String] -> FilePath -> Maybe String -> IO InspectedModule +inspectFile defines opts file mcts = hsdevLiftIO $ do + proj <- locateProject file + absFilename <- Dir.canonicalizePath file + ex <- Dir.doesFileExist absFilename + unless ex $ hsdevError $ FileNotFound absFilename inspect (FileModule absFilename proj) ((if isJust mcts then fileContentsInspection else fileInspection) absFilename opts) $ do -- docsMap <- liftE $ if hdocsWorkaround -- then hdocsProcess absFilename opts -- else liftM Just $ hdocs (FileModule absFilename Nothing) opts - forced <- ExceptT $ E.handle onError $ do + forced <- hsdevLiftWith InspectError $ ExceptT $ E.handle onError $ do analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $ maybe (readFileUtf8 absFilename >>= preprocess_ defines exts file) return mcts force analyzed `deepseq` return analyzed @@ -377,40 +379,40 @@ exts = mapMaybe flagExtension opts -- | File inspection data -fileInspection :: FilePath -> [String] -> ExceptT String IO Inspection +fileInspection :: FilePath -> [String] -> IO Inspection fileInspection f opts = do - tm <- liftE $ Dir.getModificationTime f + tm <- Dir.getModificationTime f return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ ordNub opts -- | File contents inspection data -fileContentsInspection :: FilePath -> [String] -> ExceptT String IO Inspection +fileContentsInspection :: FilePath -> [String] -> IO Inspection fileContentsInspection _ opts = do - tm <- liftE getPOSIXTime + tm <- getPOSIXTime return $ InspectionAt tm $ sort $ ordNub opts -- | Enumerate project dirs -projectDirs :: Project -> ExceptT String IO [Extensions FilePath] +projectDirs :: Project -> IO [Extensions FilePath] projectDirs p = do p' <- loadProject p return $ ordNub $ map (fmap (normalise . (view projectPath p' ))) $ maybe [] sourceDirs $ view projectDescription p' -- | Enumerate project source files -projectSources :: Project -> ExceptT String IO [Extensions FilePath] +projectSources :: Project -> IO [Extensions FilePath] projectSources p = do dirs <- projectDirs p let enumCabals = liftM (map takeDirectory . filter cabalFile) . traverseDirectory dirs' = map (view entity) dirs -- enum inner projects and dont consider them as part of this project - subProjs <- liftM (delete (view projectPath p) . ordNub . concat) $ triesMap (liftE . enumCabals) dirs' + subProjs <- liftM (delete (view projectPath p) . ordNub . concat) $ triesMap (enumCabals) dirs' let enumHs = liftM (filter thisProjectSource) . traverseDirectory thisProjectSource h = haskellSource h && not (any (`isParent` h) subProjs) - liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (liftE . enumHs)) dirs + liftM (ordNub . concat) $ triesMap (liftM sequenceA . traverse (enumHs)) dirs -- | Inspect project -inspectProject :: [(String, String)] -> [String] -> Project -> ExceptT String IO (Project, [InspectedModule]) -inspectProject defines opts p = do +inspectProject :: [(String, String)] -> [String] -> Project -> IO (Project, [InspectedModule]) +inspectProject defines opts p = hsdevLiftIO $ do p' <- loadProject p srcs <- projectSources p' modules <- mapM inspectFile' srcs @@ -433,14 +435,17 @@ onIO :: E.IOException -> IO [(String, String)] onIO _ = return [] -preprocess :: [(String, String)] -> FilePath -> String -> ExceptT String IO String +preprocess :: [(String, String)] -> FilePath -> String -> IO String preprocess defines fpath cts = do - cts' <- liftE $ Cpphs.cppIfdef fpath defines [] Cpphs.defaultBoolOptions cts + cts' <- E.catch (Cpphs.cppIfdef fpath defines [] Cpphs.defaultBoolOptions cts) onIOError return $ unlines $ map snd cts' + where + onIOError :: E.IOException -> IO [(Cpphs.Posn, String)] + onIOError _ = return [] preprocess_ :: [(String, String)] -> [String] -> FilePath -> String -> IO String preprocess_ defines exts fpath cts - | hasCPP = runExceptT (preprocess defines fpath cts) >>= either (const $ return cts) return + | hasCPP = preprocess defines fpath cts | otherwise = return cts where exts' = map H.parseExtension exts ++ maybe [] snd (H.readExtensions cts) diff --git a/src/HsDev/Project.hs b/src/HsDev/Project.hs --- a/src/HsDev/Project.hs +++ b/src/HsDev/Project.hs @@ -1,19 +1,10 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} - module HsDev.Project ( - Project(..), - ProjectDescription(..), Target(..), Library(..), Executable(..), Test(..), Info(..), infoSourceDirsDef, + module HsDev.Project.Types, + + infoSourceDirsDef, readProject, loadProject, - project, - Extensions(..), withExtensions, + withExtensions, infos, inTarget, fileTargets, findSourceDir, sourceDirs, - - projectName, projectPath, projectCabal, projectDescription, projectVersion, projectLibrary, projectExecutables, projectTests, - libraryModules, libraryBuildInfo, - executableName, executablePath, executableBuildInfo, - testName, testEnabled, testBuildInfo, - infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs, - extensions, ghcOptions, entity, targetOpts, -- * Helpers @@ -22,193 +13,24 @@ ) where import Control.Arrow -import Control.DeepSeq (NFData(..)) -import Control.Lens (makeLenses, Simple, Lens, view, lens) -import Control.Exception +import Control.Lens (Simple, Lens, view, lens) import Control.Monad.Except -import Data.Aeson -import Data.Aeson.Types (Parser) import Data.List import Data.Maybe -import Data.Monoid -import Data.Ord import Data.Version (showVersion) import Distribution.Compiler (CompilerFlavor(GHC)) import qualified Distribution.Package as P import qualified Distribution.PackageDescription as PD import Distribution.PackageDescription.Parse import Distribution.ModuleName (components) -import Distribution.Text (display, simpleParse) -import qualified Distribution.Text (Text) +import Distribution.Text (display) import Language.Haskell.Extension import System.FilePath +import HsDev.Project.Types +import HsDev.Error import HsDev.Util --- | Cabal project -data Project = Project { - _projectName :: String, - _projectPath :: FilePath, - _projectCabal :: FilePath, - _projectDescription :: Maybe ProjectDescription } - deriving (Read) - -instance NFData Project where - rnf (Project n p c _) = rnf n `seq` rnf p `seq` rnf c - -instance Eq Project where - l == r = _projectCabal l == _projectCabal r - -instance Ord Project where - compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r) - -instance Show Project where - show p = unlines $ [ - "project " ++ _projectName p, - "\tcabal: " ++ _projectCabal p, - "\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p) - -instance ToJSON Project where - toJSON p = object [ - "name" .= _projectName p, - "path" .= _projectPath p, - "cabal" .= _projectCabal p, - "description" .= _projectDescription p] - -instance FromJSON Project where - parseJSON = withObject "project" $ \v -> Project <$> - v .:: "name" <*> - v .:: "path" <*> - v .:: "cabal" <*> - v .:: "description" - -data ProjectDescription = ProjectDescription { - _projectVersion :: String, - _projectLibrary :: Maybe Library, - _projectExecutables :: [Executable], - _projectTests :: [Test] } - deriving (Eq, Read) - -instance Show ProjectDescription where - show pd = unlines $ - concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++ - concatMap (lines . show) (_projectExecutables pd) ++ - concatMap (lines . show) (_projectTests pd) - -instance ToJSON ProjectDescription where - toJSON d = object [ - "version" .= _projectVersion d, - "library" .= _projectLibrary d, - "executables" .= _projectExecutables d, - "tests" .= _projectTests d] - -instance FromJSON ProjectDescription where - parseJSON = withObject "project description" $ \v -> ProjectDescription <$> - v .:: "version" <*> - v .:: "library" <*> - v .:: "executables" <*> - v .:: "tests" - -class Target a where - buildInfo :: a -> Info - --- | Library in project -data Library = Library { - _libraryModules :: [[String]], - _libraryBuildInfo :: Info } - deriving (Eq, Read) - -instance Target Library where - buildInfo = _libraryBuildInfo - -instance Show Library where - show l = unlines $ - ["library", "\tmodules:"] ++ - (map (tab 2 . intercalate ".") $ _libraryModules l) ++ - (map (tab 1) . lines . show $ _libraryBuildInfo l) - -instance ToJSON Library where - toJSON l = object [ - "modules" .= fmap (intercalate ".") (_libraryModules l), - "info" .= _libraryBuildInfo l] - -instance FromJSON Library where - parseJSON = withObject "library" $ \v -> Library <$> (fmap splitModule <$> v .:: "modules") <*> v .:: "info" where - splitModule :: String -> [String] - splitModule = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break (== '.')) - --- | Executable -data Executable = Executable { - _executableName :: String, - _executablePath :: FilePath, - _executableBuildInfo :: Info } - deriving (Eq, Read) - -instance Target Executable where - buildInfo = _executableBuildInfo - -instance Show Executable where - show e = unlines $ - ["executable " ++ _executableName e, "\tpath: " ++ _executablePath e] ++ - (map (tab 1) . lines . show $ _executableBuildInfo e) - -instance ToJSON Executable where - toJSON e = object [ - "name" .= _executableName e, - "path" .= _executablePath e, - "info" .= _executableBuildInfo e] - -instance FromJSON Executable where - parseJSON = withObject "executable" $ \v -> Executable <$> - v .:: "name" <*> - v .:: "path" <*> - v .:: "info" - --- | Test -data Test = Test { - _testName :: String, - _testEnabled :: Bool, - _testBuildInfo :: Info } - deriving (Eq, Read) - -instance Target Test where - buildInfo = _testBuildInfo - -instance Show Test where - show t = unlines $ - ["test " ++ _testName t, "\tenabled: " ++ show (_testEnabled t)] ++ - (map (tab 1) . lines . show $ _testBuildInfo t) - -instance ToJSON Test where - toJSON t = object [ - "name" .= _testName t, - "enabled" .= _testEnabled t, - "info" .= _testBuildInfo t] - -instance FromJSON Test where - parseJSON = withObject "test" $ \v -> Test <$> - v .:: "name" <*> - v .:: "enabled" <*> - v .:: "info" - --- | Build info -data Info = Info { - _infoDepends :: [String], - _infoLanguage :: Maybe Language, - _infoExtensions :: [Extension], - _infoGHCOptions :: [String], - _infoSourceDirs :: [FilePath] } - deriving (Eq, Read) - -instance Monoid Info where - mempty = Info [] Nothing [] [] [] - mappend l r = Info - (ordNub $ _infoDepends l ++ _infoDepends r) - (getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r)) - (_infoExtensions l ++ _infoExtensions r) - (_infoGHCOptions l ++ _infoGHCOptions r) - (ordNub $ _infoSourceDirs l ++ _infoSourceDirs r) - -- | infoSourceDirs lens with default infoSourceDirsDef :: Simple Lens Info [FilePath] infoSourceDirsDef = lens get' set' where @@ -218,33 +40,6 @@ set' i ["."] = i { _infoSourceDirs = [] } set' i dirs = i { _infoSourceDirs = dirs } -instance Show Info where - show i = unlines $ lang ++ exts ++ opts ++ sources where - lang = maybe [] (\l -> ["default-language: " ++ display l]) $ _infoLanguage i - exts - | null (_infoExtensions i) = [] - | otherwise = "extensions:" : map (tab 1 . display) (_infoExtensions i) - opts - | null (_infoGHCOptions i) = [] - | otherwise = "ghc-options:" : map (tab 1) (_infoGHCOptions i) - sources = "source-dirs:" : (map (tab 1) $ _infoSourceDirs i) - -instance ToJSON Info where - toJSON i = object [ - "build-depends" .= _infoDepends i, - "language" .= fmap display (_infoLanguage i), - "extensions" .= map display (_infoExtensions i), - "ghc-options" .= _infoGHCOptions i, - "source-dirs" .= _infoSourceDirs i] - -instance FromJSON Info where - parseJSON = withObject "info" $ \v -> Info <$> - v .: "build-depends" <*> - ((v .:: "language") >>= traverse (parseDT "Language")) <*> - ((v .:: "extensions") >>= traverse (parseDT "Extension")) <*> - v .:: "ghc-options" <*> - v .:: "source-dirs" - -- | Analyze cabal file analyzeCabal :: String -> Either String ProjectDescription analyzeCabal source = case liftM flattenDescr $ parsePackageDescription source of @@ -287,56 +82,20 @@ flattenBranch (_, t, mb) = flattenTree f t : map (flattenTree f) (maybeToList mb) -- | Read project info from .cabal -readProject :: FilePath -> ExceptT String IO Project +readProject :: FilePath -> IO Project readProject file = do - source <- ExceptT $ handle (\e -> return (Left ("IO error: " ++ show (e :: IOException)))) (fmap Right $ readFile file) - length source `seq` either throwError (return . mkProject) $ analyzeCabal source + source <- readFile file + length source `seq` either (hsdevError . InspectCabalError file) (return . mkProject) $ analyzeCabal source where mkProject desc = (project file) { _projectDescription = Just desc } -- | Load project description -loadProject :: Project -> ExceptT String IO Project +loadProject :: Project -> IO Project loadProject p | isJust (_projectDescription p) = return p | otherwise = readProject (_projectCabal p) --- | Make project by .cabal file -project :: FilePath -> Project -project file = Project { - _projectName = takeBaseName (takeDirectory cabal), - _projectPath = takeDirectory cabal, - _projectCabal = cabal, - _projectDescription = Nothing } - where - file' = dropTrailingPathSeparator $ normalise file - cabal - | takeExtension file' == ".cabal" = file' - | otherwise = file' (takeBaseName file' <.> "cabal") - --- | Entity with project extensions -data Extensions a = Extensions { - _extensions :: [Extension], - _ghcOptions :: [String], - _entity :: a } - deriving (Eq, Read, Show) - -instance Ord a => Ord (Extensions a) where - compare = comparing _entity - -instance Functor Extensions where - fmap f (Extensions e o x) = Extensions e o (f x) - -instance Applicative Extensions where - pure = Extensions [] [] - (Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x) - -instance Foldable Extensions where - foldMap f (Extensions _ _ x) = f x - -instance Traversable Extensions where - traverse f (Extensions e o x) = Extensions e o <$> f x - -- | Extensions for target withExtensions :: a -> Info -> Extensions a withExtensions x i = Extensions { @@ -376,10 +135,6 @@ sourceDirs = ordNub . concatMap dirs . infos where dirs i = map (`withExtensions` i) $ view infoSourceDirsDef i -parseDT :: Distribution.Text.Text a => String -> String -> Parser a -parseDT typeName v = maybe err return (simpleParse v) where - err = fail $ "Can't parse " ++ typeName ++ ": " ++ v - -- | Get options for specific target targetOpts :: Info -> [String] targetOpts info' = concat [ @@ -402,11 +157,3 @@ -- | Extensions as opts to GHC extensionsOpts :: Extensions a -> [String] extensionsOpts e = map (extensionFlag . showExtension) (_extensions e) ++ _ghcOptions e - -makeLenses ''Project -makeLenses ''ProjectDescription -makeLenses ''Library -makeLenses ''Executable -makeLenses ''Test -makeLenses ''Info -makeLenses ''Extensions diff --git a/src/HsDev/Project/Types.hs b/src/HsDev/Project/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Project/Types.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} + +module HsDev.Project.Types ( + Project(..), projectName, projectPath, projectCabal, projectDescription, project, + ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests, + Target(..), + Library(..), libraryModules, libraryBuildInfo, + Executable(..), executableName, executablePath, executableBuildInfo, + Test(..), testName, testEnabled, testBuildInfo, + Info(..), infoDepends, infoLanguage, infoExtensions, infoGHCOptions, infoSourceDirs, + Extensions(..), extensions, ghcOptions, entity, + ) where + +import Control.Arrow +import Control.DeepSeq (NFData(..)) +import Control.Lens (makeLenses) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Distribution.Text (display, simpleParse) +import qualified Distribution.Text (Text) +import Language.Haskell.Extension +import Text.Format +import System.FilePath + +import HsDev.Util + +-- | Cabal project +data Project = Project { + _projectName :: String, + _projectPath :: FilePath, + _projectCabal :: FilePath, + _projectDescription :: Maybe ProjectDescription } + deriving (Read) + +instance NFData Project where + rnf (Project n p c _) = rnf n `seq` rnf p `seq` rnf c + +instance Eq Project where + l == r = _projectCabal l == _projectCabal r + +instance Ord Project where + compare l r = compare (_projectName l, _projectCabal l) (_projectName r, _projectCabal r) + +instance Show Project where + show p = unlines $ [ + "project " ++ _projectName p, + "\tcabal: " ++ _projectCabal p, + "\tdescription:"] ++ concatMap (map (tab 2) . lines . show) (maybeToList $ _projectDescription p) + +instance ToJSON Project where + toJSON p = object [ + "name" .= _projectName p, + "path" .= _projectPath p, + "cabal" .= _projectCabal p, + "description" .= _projectDescription p] + +instance FromJSON Project where + parseJSON = withObject "project" $ \v -> Project <$> + v .:: "name" <*> + v .:: "path" <*> + v .:: "cabal" <*> + v .:: "description" + +-- | Make project by .cabal file +project :: FilePath -> Project +project file = Project { + _projectName = takeBaseName (takeDirectory cabal), + _projectPath = takeDirectory cabal, + _projectCabal = cabal, + _projectDescription = Nothing } + where + file' = dropTrailingPathSeparator $ normalise file + cabal + | takeExtension file' == ".cabal" = file' + | otherwise = file' (takeBaseName file' <.> "cabal") + +data ProjectDescription = ProjectDescription { + _projectVersion :: String, + _projectLibrary :: Maybe Library, + _projectExecutables :: [Executable], + _projectTests :: [Test] } + deriving (Eq, Read) + +instance Show ProjectDescription where + show pd = unlines $ + concatMap (lines . show) (maybeToList (_projectLibrary pd)) ++ + concatMap (lines . show) (_projectExecutables pd) ++ + concatMap (lines . show) (_projectTests pd) + +instance ToJSON ProjectDescription where + toJSON d = object [ + "version" .= _projectVersion d, + "library" .= _projectLibrary d, + "executables" .= _projectExecutables d, + "tests" .= _projectTests d] + +instance FromJSON ProjectDescription where + parseJSON = withObject "project description" $ \v -> ProjectDescription <$> + v .:: "version" <*> + v .:: "library" <*> + v .:: "executables" <*> + v .:: "tests" + +class Target a where + buildInfo :: a -> Info + +-- | Library in project +data Library = Library { + _libraryModules :: [[String]], + _libraryBuildInfo :: Info } + deriving (Eq, Read) + +instance Target Library where + buildInfo = _libraryBuildInfo + +instance Show Library where + show l = unlines $ + ["library", "\tmodules:"] ++ + (map (tab 2 . intercalate ".") $ _libraryModules l) ++ + (map (tab 1) . lines . show $ _libraryBuildInfo l) + +instance ToJSON Library where + toJSON l = object [ + "modules" .= fmap (intercalate ".") (_libraryModules l), + "info" .= _libraryBuildInfo l] + +instance FromJSON Library where + parseJSON = withObject "library" $ \v -> Library <$> (fmap splitModule <$> v .:: "modules") <*> v .:: "info" where + splitModule :: String -> [String] + splitModule = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break (== '.')) + +-- | Executable +data Executable = Executable { + _executableName :: String, + _executablePath :: FilePath, + _executableBuildInfo :: Info } + deriving (Eq, Read) + +instance Target Executable where + buildInfo = _executableBuildInfo + +instance Show Executable where + show e = unlines $ + ["executable " ++ _executableName e, "\tpath: " ++ _executablePath e] ++ + (map (tab 1) . lines . show $ _executableBuildInfo e) + +instance ToJSON Executable where + toJSON e = object [ + "name" .= _executableName e, + "path" .= _executablePath e, + "info" .= _executableBuildInfo e] + +instance FromJSON Executable where + parseJSON = withObject "executable" $ \v -> Executable <$> + v .:: "name" <*> + v .:: "path" <*> + v .:: "info" + +-- | Test +data Test = Test { + _testName :: String, + _testEnabled :: Bool, + _testBuildInfo :: Info } + deriving (Eq, Read) + +instance Target Test where + buildInfo = _testBuildInfo + +instance Show Test where + show t = unlines $ + ["test " ++ _testName t, "\tenabled: " ++ show (_testEnabled t)] ++ + (map (tab 1) . lines . show $ _testBuildInfo t) + +instance ToJSON Test where + toJSON t = object [ + "name" .= _testName t, + "enabled" .= _testEnabled t, + "info" .= _testBuildInfo t] + +instance FromJSON Test where + parseJSON = withObject "test" $ \v -> Test <$> + v .:: "name" <*> + v .:: "enabled" <*> + v .:: "info" + +-- | Build info +data Info = Info { + _infoDepends :: [String], + _infoLanguage :: Maybe Language, + _infoExtensions :: [Extension], + _infoGHCOptions :: [String], + _infoSourceDirs :: [FilePath] } + deriving (Eq, Read) + +instance Monoid Info where + mempty = Info [] Nothing [] [] [] + mappend l r = Info + (ordNub $ _infoDepends l ++ _infoDepends r) + (getFirst $ First (_infoLanguage l) `mappend` First (_infoLanguage r)) + (_infoExtensions l ++ _infoExtensions r) + (_infoGHCOptions l ++ _infoGHCOptions r) + (ordNub $ _infoSourceDirs l ++ _infoSourceDirs r) + +instance Show Info where + show i = unlines $ lang ++ exts ++ opts ++ sources where + lang = maybe [] (\l -> ["default-language: " ++ display l]) $ _infoLanguage i + exts + | null (_infoExtensions i) = [] + | otherwise = "extensions:" : map (tab 1 . display) (_infoExtensions i) + opts + | null (_infoGHCOptions i) = [] + | otherwise = "ghc-options:" : map (tab 1) (_infoGHCOptions i) + sources = "source-dirs:" : (map (tab 1) $ _infoSourceDirs i) + +instance ToJSON Info where + toJSON i = object [ + "build-depends" .= _infoDepends i, + "language" .= fmap display (_infoLanguage i), + "extensions" .= map display (_infoExtensions i), + "ghc-options" .= _infoGHCOptions i, + "source-dirs" .= _infoSourceDirs i] + +instance FromJSON Info where + parseJSON = withObject "info" $ \v -> Info <$> + v .: "build-depends" <*> + ((v .:: "language") >>= traverse (parseDT "Language")) <*> + ((v .:: "extensions") >>= traverse (parseDT "Extension")) <*> + v .:: "ghc-options" <*> + v .:: "source-dirs" + where + parseDT :: Distribution.Text.Text a => String -> String -> Parser a + parseDT typeName v = maybe err return (simpleParse v) where + err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v + +-- | Entity with project extensions +data Extensions a = Extensions { + _extensions :: [Extension], + _ghcOptions :: [String], + _entity :: a } + deriving (Eq, Read, Show) + +instance Ord a => Ord (Extensions a) where + compare = comparing _entity + +instance Functor Extensions where + fmap f (Extensions e o x) = Extensions e o (f x) + +instance Applicative Extensions where + pure = Extensions [] [] + (Extensions l lo f) <*> (Extensions r ro x) = Extensions (ordNub $ l ++ r) (ordNub $ lo ++ ro) (f x) + +instance Foldable Extensions where + foldMap f (Extensions _ _ x) = f x + +instance Traversable Extensions where + traverse f (Extensions e o x) = Extensions e o <$> f x + +makeLenses ''Project +makeLenses ''ProjectDescription +makeLenses ''Library +makeLenses ''Executable +makeLenses ''Test +makeLenses ''Info +makeLenses ''Extensions diff --git a/src/HsDev/Sandbox.hs b/src/HsDev/Sandbox.hs --- a/src/HsDev/Sandbox.hs +++ b/src/HsDev/Sandbox.hs @@ -12,6 +12,7 @@ import Control.Arrow import Control.DeepSeq (NFData(..)) +import Control.Monad.Catch (MonadCatch(..)) import Control.Monad.Trans.Maybe import Control.Monad.Except import Control.Lens (view, makeLenses) @@ -24,6 +25,7 @@ import qualified Distribution.Text as T (display) import System.FilePath import System.Directory +import System.Log.Simple (MonadLog(..)) import System.Directory.Paths import HsDev.PackageDb @@ -93,31 +95,30 @@ searchSandbox p = runMaybeT $ searchPath p (MaybeT . findSandbox) -- | Get package-db stack for sandbox -sandboxPackageDbStack :: Sandbox -> ExceptT String IO PackageDbStack +sandboxPackageDbStack :: (MonadLog m, MonadCatch m) => Sandbox -> m PackageDbStack sandboxPackageDbStack (Sandbox CabalSandbox fpath) = do dir <- cabalSandboxPackageDb return $ PackageDbStack [PackageDb $ fpath dir] -sandboxPackageDbStack (Sandbox StackWork fpath) = maybeToExceptT "Can't locate stack environment" $ - liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory fpath +sandboxPackageDbStack (Sandbox StackWork fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory fpath -- | Search package-db stack with user-db as default -searchPackageDbStack :: FilePath -> IO PackageDbStack +searchPackageDbStack :: (MonadLog m, MonadCatch m) => FilePath -> m PackageDbStack searchPackageDbStack p = do - mbox <- searchSandbox p + mbox <- liftIO $ searchSandbox p case mbox of Nothing -> return userDb - Just sbox -> liftM (either (const userDb) id) $ runExceptT $ sandboxPackageDbStack sbox + Just sbox -> sandboxPackageDbStack sbox -- | Restore package-db stack by package-db -restorePackageDbStack :: PackageDb -> IO PackageDbStack +restorePackageDbStack :: (MonadLog m, MonadCatch m) => PackageDb -> m PackageDbStack restorePackageDbStack GlobalDb = return globalDb restorePackageDbStack UserDb = return userDb restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDb p) $ runMaybeT $ do - sbox <- MaybeT $ searchSandbox p - exceptToMaybeT $ sandboxPackageDbStack sbox + sbox <- MaybeT $ liftIO $ searchSandbox p + lift $ sandboxPackageDbStack sbox -- | Get actual sandbox build path: --- -cabalSandboxLib :: ExceptT String IO FilePath +cabalSandboxLib :: MonadLog m => m FilePath cabalSandboxLib = do res <- withPackages ["-no-user-package-db"] $ return . @@ -131,5 +132,5 @@ return $ T.display buildPlatform ++ "-" ++ compiler ++ "-" ++ ver -- | Get sandbox package-db: ----packages.conf.d -cabalSandboxPackageDb :: ExceptT String IO FilePath +cabalSandboxPackageDb :: MonadLog m => m FilePath cabalSandboxPackageDb = liftM (++ "-packages.conf.d") cabalSandboxLib diff --git a/src/HsDev/Scan.hs b/src/HsDev/Scan.hs --- a/src/HsDev/Scan.hs +++ b/src/HsDev/Scan.hs @@ -19,13 +19,14 @@ import Control.DeepSeq import Control.Lens (view, preview, set, over, each, _Right, _1, _2, _3, (^.), (^..)) import Control.Monad.Except -import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import Data.List (intercalate) import System.Directory import Text.Format -import HsDev.Scan.Browse (browsePackages) -import HsDev.Server.Types (FileContents(..)) +import HsDev.Error +import HsDev.Scan.Browse (browsePackages, browseModules) +import HsDev.Server.Types (FileContents(..), CommandMonad(..)) import HsDev.Sandbox import HsDev.Symbols import HsDev.Symbols.Types @@ -69,7 +70,7 @@ ~~ (intercalate ", " $ map (display . topPackageDb) $ cs ^.. each) class EnumContents a where - enumContents :: a -> ExceptT String IO ScanContents + enumContents :: CommandMonad m => a -> m ScanContents instance EnumContents ModuleLocation where enumContents mloc = return $ ScanContents [(mloc, [], Nothing)] [] [] @@ -91,8 +92,8 @@ instance {-# OVERLAPS #-} EnumContents FilePath where enumContents f - | haskellSource f = do - mproj <- liftEIO $ locateProject f + | haskellSource f = hsdevLiftIO $ do + mproj <- liftIO $ locateProject f case mproj of Nothing -> enumContents $ FileModule f Nothing Just proj -> do @@ -108,10 +109,10 @@ | otherwise = return mempty -- | Enum project sources -enumProject :: Project -> ExceptT String IO ScanContents -enumProject p = do - p' <- loadProject p - pdbs <- liftE $ searchPackageDbStack (view projectPath p') +enumProject :: CommandMonad m => Project -> m ScanContents +enumProject p = hsdevLiftIO $ do + p' <- liftIO $ loadProject p + pdbs <- searchPackageDbStack (view projectPath p') pkgs <- liftM (map $ view (package . packageName)) $ browsePackages [] pdbs let projOpts :: FilePath -> [String] @@ -121,25 +122,25 @@ ["-hide-all-packages"], ["-package " ++ view projectName p'], ["-package " ++ dep | dep <- view infoDepends i, dep `elem` pkgs]] - srcs <- projectSources p' + srcs <- liftIO $ projectSources p' let mlocs = over each (\src -> over ghcOptions (++ projOpts (view entity src)) . over entity (\f -> FileModule f (Just p')) $ src) srcs mods <- liftM modulesToScan $ enumContents mlocs return $ ScanContents [] [(p', mods)] [] -- (sandboxCabals sboxes) -- | Enum sandbox -enumSandbox :: Sandbox -> ExceptT String IO ScanContents +enumSandbox :: CommandMonad m => Sandbox -> m ScanContents enumSandbox = sandboxPackageDbStack >=> enumContents -- | Enum directory modules -enumDirectory :: FilePath -> ExceptT String IO ScanContents -enumDirectory dir = do - cts <- liftException $ traverseDirectory dir +enumDirectory :: CommandMonad m => FilePath -> m ScanContents +enumDirectory dir = hsdevLiftIO $ do + cts <- liftIO $ traverseDirectory dir let projects = filter cabalFile cts sources = filter haskellSource cts - dirs <- liftE $ filterM doesDirectoryExist cts - sboxes <- liftM catMaybes $ triesMap (liftE . findSandbox) dirs + dirs <- liftIO $ filterM doesDirectoryExist cts + sboxes <- liftM catMaybes $ triesMap (liftIO . findSandbox) dirs pdbs <- mapM enumSandbox sboxes projs <- liftM mconcat $ triesMap (enumProject . project) projects let @@ -151,14 +152,14 @@ mconcat pdbs] -- | Scan project file -scanProjectFile :: [String] -> FilePath -> ExceptT String IO Project -scanProjectFile _ f = do - proj <- (liftE $ locateProject f) >>= maybe (throwError "Can't locate project") return - loadProject proj +scanProjectFile :: CommandMonad m => [String] -> FilePath -> m Project +scanProjectFile _ f = hsdevLiftIO $ do + proj <- (liftIO $ locateProject f) >>= maybe (hsdevError $ FileNotFound f) return + liftIO $ loadProject proj -- | Scan module -scanModule :: [(String, String)] -> [String] -> ModuleLocation -> Maybe String -> ExceptT String IO InspectedModule -scanModule defines opts (FileModule f p) mcts = liftM setProj $ inspectFile defines opts f mcts where +scanModule :: CommandMonad m => [(String, String)] -> [String] -> ModuleLocation -> Maybe String -> m InspectedModule +scanModule defines opts (FileModule f p) mcts = hsdevLiftIO $ liftM setProj $ liftIO $ inspectFile defines opts f mcts where setProj = set (inspectedId . moduleProject) p . set (inspectionResult . _Right . moduleLocation . moduleProject) p @@ -166,19 +167,20 @@ -- infer' m = tryInfer <|> return m where -- tryInfer = mapExceptT (withCurrentDirectory (sourceModuleRoot (moduleName m) f)) $ -- runGhcMod defaultOptions $ inferTypes opts Cabal m -scanModule _ opts (InstalledModule c p n) _ = do - pdbs <- liftIO $ getDbs c - browse opts pdbs n p +scanModule _ opts mloc@(InstalledModule c _ n) _ = hsdevLiftIO $ do + pdbs <- getDbs c + ims <- browseModules opts pdbs [mloc] + maybe (hsdevError $ BrowseNoModuleInfo n) return $ listToMaybe ims where - getDbs :: PackageDb -> IO PackageDbStack + getDbs :: CommandMonad m => PackageDb -> m PackageDbStack getDbs = maybe (return userDb) searchPackageDbStack . preview packageDb -scanModule _ _ (ModuleSource _) _ = throwError "Can inspect only modules in file or cabal" +scanModule _ _ (ModuleSource _) _ = hsdevError $ InspectError "Can inspect only modules in file or cabal" -- | Scan additional info and modify scanned module -scanModify :: ([String] -> PackageDbStack -> Module -> ExceptT String IO Module) -> InspectedModule -> ExceptT String IO InspectedModule +scanModify :: CommandMonad m => ([String] -> PackageDbStack -> Module -> m Module) -> InspectedModule -> m InspectedModule scanModify f im = traverse f' im where f' m = do - pdbs <- liftIO $ case view moduleLocation m of + pdbs <- case view moduleLocation m of -- TODO: Get actual sandbox stack FileModule fpath _ -> searchPackageDbStack fpath InstalledModule pdb _ _ -> maybe (return userDb) searchPackageDbStack $ preview packageDb pdb @@ -186,27 +188,27 @@ f (fromMaybe [] $ preview (inspection . inspectionOpts) im) pdbs m -- | Is inspected module up to date? -upToDate :: [String] -> InspectedModule -> ExceptT String IO Bool -upToDate opts (Inspected insp m _) = case m of - FileModule f _ -> liftM (== insp) $ fileInspection f opts - InstalledModule _ _ _ -> return $ insp == browseInspection opts +upToDate :: [String] -> InspectedModule -> IO Bool +upToDate opts im = case view inspectedId im of + FileModule f _ -> liftM (== view inspection im) $ fileInspection f opts + InstalledModule _ _ _ -> return $ view inspection im == browseInspection opts _ -> return False -- | Rescan inspected module -rescanModule :: [(String, String)] -> [String] -> InspectedModule -> ExceptT String IO (Maybe InspectedModule) +rescanModule :: CommandMonad m => [(String, String)] -> [String] -> InspectedModule -> m (Maybe InspectedModule) rescanModule defines opts im = do - up <- upToDate opts im + up <- liftIO $ upToDate opts im if up then return Nothing else fmap Just $ scanModule defines opts (view inspectedId im) Nothing -- | Is module new or recently changed -changedModule :: Database -> [String] -> ModuleLocation -> ExceptT String IO Bool -changedModule db opts m = maybe (return True) (liftM not . upToDate opts) m' where +changedModule :: Database -> [String] -> ModuleLocation -> IO Bool +changedModule db opts m = maybe (return True) (liftM not . liftIO . upToDate opts) m' where m' = lookupInspected m db -- | Returns new (to scan) and changed (to rescan) modules -changedModules :: Database -> [String] -> [ModuleToScan] -> ExceptT String IO [ModuleToScan] +changedModules :: Database -> [String] -> [ModuleToScan] -> IO [ModuleToScan] changedModules db opts = filterM $ \m -> if isJust (m ^. _3) then return True else changedModule db (opts ++ (m ^. _2)) (m ^. _1) diff --git a/src/HsDev/Scan/Browse.hs b/src/HsDev/Scan/Browse.hs --- a/src/HsDev/Scan/Browse.hs +++ b/src/HsDev/Scan/Browse.hs @@ -14,6 +14,7 @@ import Control.Arrow import Control.Lens (view, preview, _Just) +import Control.Monad.Catch (MonadCatch, catch, SomeException) import Control.Monad.Except import Data.List (isPrefixOf) import Data.Maybe @@ -21,12 +22,15 @@ import Data.Version import System.Directory import System.FilePath +import System.Log.Simple.Monad (MonadLog) import Data.Deps import HsDev.PackageDb import HsDev.Symbols +import HsDev.Error import HsDev.Tools.Base (inspect) -import HsDev.Util (liftIOErrors, ordNub) +import HsDev.Tools.Ghc.Worker (GhcM(..), runGhcM) +import HsDev.Util (ordNub) import qualified ConLike as GHC import qualified DataCon as GHC @@ -34,6 +38,7 @@ import qualified GHC import qualified GHC.PackageDb as GHC import qualified GhcMonad as GHC (liftIO) +import GhcMonad (GhcMonad) import qualified GHC.Paths as GHC import qualified Name as GHC import qualified Outputable as GHC @@ -45,49 +50,47 @@ import Pretty -- | Browse packages -browsePackages :: [String] -> PackageDbStack -> ExceptT String IO [PackageConfig] -browsePackages opts dbs = liftIOErrors $ withPackages_ (packageDbStackOpts dbs ++ opts) $ - liftM (map readPackageConfig) $ lift packageConfigs +browsePackages :: MonadLog m => [String] -> PackageDbStack -> m [PackageConfig] +browsePackages opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $ + liftM (map readPackageConfig) packageConfigs -- | Get packages with deps -browsePackagesDeps :: [String] -> PackageDbStack -> ExceptT String IO (Deps PackageConfig) -browsePackagesDeps opts dbs = liftIOErrors $ withPackages (packageDbStackOpts dbs ++ opts) $ \df -> do - cfgs <- lift packageConfigs +browsePackagesDeps :: MonadLog m => [String] -> PackageDbStack -> m (Deps PackageConfig) +browsePackagesDeps opts dbs = withPackages (packageDbStackOpts dbs ++ opts) $ \df -> do + cfgs <- packageConfigs return $ mapDeps (toPkg df) $ mconcat $ map (uncurry deps) $ map (GHC.installedPackageId &&& GHC.depends) cfgs where toPkg df' = readPackageConfig . GHC.getPackageDetails df' . GHC.resolveInstalledPackageId df' -listModules :: [String] -> PackageDbStack -> ExceptT String IO [ModuleLocation] -listModules opts dbs = liftIOErrors $ withPackages_ (packageDbStackOpts dbs ++ opts) $ do - ms <- lift packageDbModules +listModules :: MonadLog m => [String] -> PackageDbStack -> m [ModuleLocation] +listModules opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do + ms <- packageDbModules pdbs <- mapM (liftIO . ghcPackageDb . fst) ms return [ghcModuleLocation pdb p m | (pdb, (p, m)) <- zip pdbs ms] -browseModules :: [String] -> PackageDbStack -> [ModuleLocation] -> ExceptT String IO [InspectedModule] -browseModules opts dbs mlocs = liftIOErrors $ withPackages_ (packageDbStackOpts dbs ++ opts) $ do - ms <- lift packageDbModules +browseModules :: MonadLog m => [String] -> PackageDbStack -> [ModuleLocation] -> m [InspectedModule] +browseModules opts dbs mlocs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do + ms <- packageDbModules pdbs <- mapM (liftIO . ghcPackageDb . fst) ms liftM catMaybes $ sequence [browseModule' pdb p m | (pdb, (p, m)) <- zip pdbs ms, ghcModuleLocation pdb p m `elem` mlocs] where - browseModule' :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ExceptT String GHC.Ghc (Maybe InspectedModule) + browseModule' :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM (Maybe InspectedModule) browseModule' pdb p m = tryT $ inspect (ghcModuleLocation pdb p m) (return $ InspectionAt 0 opts) (browseModule pdb p m) -- | Browse modules, if third argument is True - browse only modules in top of package-db stack -browse :: [String] -> PackageDbStack -> ExceptT String IO [InspectedModule] +browse :: MonadLog m => [String] -> PackageDbStack -> m [InspectedModule] browse opts dbs = listModules opts dbs >>= browseModules opts dbs -- | Browse modules in top of package-db stack -browseDb :: [String] -> PackageDbStack -> ExceptT String IO [InspectedModule] +browseDb :: MonadLog m => [String] -> PackageDbStack -> m [InspectedModule] browseDb opts dbs = listModules opts dbs >>= browseModules opts dbs . filter inTop where inTop = (== Just (topPackageDb dbs)) . preview modulePackageDb -browseModule :: PackageDb -> GHC.PackageConfig -> GHC.Module -> ExceptT String GHC.Ghc Module +browseModule :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM Module browseModule pdb package' m = do - mi <- lift (GHC.getModuleInfo m) >>= maybe (throwError "Can't find module info") return + mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return ds <- mapM (toDecl mi) (GHC.modInfoExports mi) - let - thisModule = GHC.moduleNameString (GHC.moduleName m) return Module { _moduleName = fromString thisModule, _moduleDocs = Nothing, @@ -96,15 +99,16 @@ _moduleImports = [import_ iname | iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString thisModule], _moduleDeclarations = sortDeclarations ds } where + thisModule = GHC.moduleNameString (GHC.moduleName m) thisLoc = view moduleIdLocation $ mloc m mloc m' = ModuleId (fromString mname') $ ghcModuleLocation pdb package' m' where mname' = GHC.moduleNameString $ GHC.moduleName m' toDecl minfo n = do - tyInfo <- lift $ GHC.modInfoLookupName minfo n - tyResult <- lift $ maybe (inModuleSource n) (return . Just) tyInfo - dflag <- lift GHC.getSessionDynFlags + tyInfo <- GHC.modInfoLookupName minfo n + tyResult <- maybe (inModuleSource n) (return . Just) tyInfo + dflag <- GHC.getSessionDynFlags let decl' = decl (fromString $ GHC.getOccString n) $ fromMaybe (Function Nothing [] Nothing) @@ -125,8 +129,8 @@ | otherwise = Type showResult _ _ = Nothing -withInitializedPackages :: [String] -> (GHC.DynFlags -> GHC.Ghc a) -> IO a -withInitializedPackages ghcOpts cont = GHC.runGhc (Just GHC.libdir) $ do +withInitializedPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a +withInitializedPackages ghcOpts cont = runGhcM (Just GHC.libdir) $ do fs <- GHC.getSessionDynFlags GHC.defaultCleanupHandler fs $ do (fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts) @@ -134,13 +138,13 @@ (result, _) <- GHC.liftIO $ GHC.initPackages fs' cont result -withPackages :: [String] -> (GHC.DynFlags -> ExceptT String GHC.Ghc a) -> ExceptT String IO a -withPackages ghcOpts cont = ExceptT $ withInitializedPackages ghcOpts (runExceptT . cont) +withPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a +withPackages ghcOpts cont = withInitializedPackages ghcOpts cont -withPackages_ :: [String] -> ExceptT String GHC.Ghc a -> ExceptT String IO a +withPackages_ :: MonadLog m => [String] -> GhcM a -> m a withPackages_ ghcOpts act = withPackages ghcOpts (const act) -inModuleSource :: GHC.Name -> GHC.Ghc (Maybe GHC.TyThing) +inModuleSource :: GhcMonad m => GHC.Name -> m (Maybe GHC.TyThing) inModuleSource nm = GHC.getModuleInfo (GHC.nameModule nm) >> GHC.lookupGlobalName nm formatType :: GHC.NamedThing a => GHC.DynFlags -> (a -> GHC.Type) -> a -> String @@ -166,8 +170,8 @@ styleUnqualified :: GHC.PprStyle styleUnqualified = GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay -tryT :: Monad m => ExceptT e m a -> ExceptT e m (Maybe a) -tryT act = catchError (liftM Just act) (const $ return Nothing) +tryT :: MonadCatch m => m a -> m (Maybe a) +tryT act = catch (liftM Just act) (const (return Nothing) . (id :: SomeException -> SomeException)) readPackage :: GHC.PackageConfig -> ModulePackage readPackage pc = ModulePackage (GHC.packageNameString pc) (showVersion (GHC.packageVersion pc)) @@ -224,10 +228,10 @@ packageDbCandidate_ :: FilePath -> IO PackageDb packageDbCandidate_ = packageDbCandidate >=> maybe (return GlobalDb) return -packageConfigs :: GHC.GhcMonad m => m [GHC.PackageConfig] +packageConfigs :: GhcM [GHC.PackageConfig] packageConfigs = liftM (fromMaybe [] . GHC.pkgDatabase) GHC.getSessionDynFlags -packageDbModules :: GHC.GhcMonad m => m [(GHC.PackageConfig, GHC.Module)] +packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module)] packageDbModules = do pkgs <- packageConfigs dflags <- GHC.getSessionDynFlags diff --git a/src/HsDev/Server/Base.hs b/src/HsDev/Server/Base.hs --- a/src/HsDev/Server/Base.hs +++ b/src/HsDev/Server/Base.hs @@ -50,29 +50,36 @@ #endif -- | Inits log chan and returns functions (print message, wait channel) -initLog :: ServerOpts -> IO (Log, Log.Level -> String -> IO (), IO [String], IO ()) +initLog :: ServerOpts -> IO SessionLog initLog sopts = do msgs <- F.newChan - l <- newLog (constant [rule']) $ concat [ + rulesVar <- newMVar [ruleStr] + let + getRules = do + rs <- readMVar rulesVar + return $ map (parseRule_ . fromString) rs + l <- newLog (return getRules) $ concat [ [logger text console | not $ serverSilent sopts], [logger text (chaner msgs)], maybeToList $ (logger text . file) <$> serverLog sopts] Log.writeLog l Log.Info ("Log politics: low = {}, high = {}" ~~ logLow ~~ logHigh) let listenLog = F.dupChan msgs >>= F.readChan - return (l, \lev -> writeLog l lev . T.pack, listenLog, stopLog l) + return $ SessionLog l rulesVar listenLog (stopLog l) where - rule' :: Log.Rule - rule' = parseRule_ $ T.pack ("/: " ++ serverLogConfig sopts) - (Log.Politics logLow logHigh) = Log.rulePolitics rule' Log.defaultPolitics + ruleStr :: String + ruleStr = "/: {}" ~~ serverLogConfig sopts + (Log.Politics logLow logHigh) = Log.rulePolitics (parseRule_ (fromString ruleStr)) Log.defaultPolitics instance FormatBuild Log.Level where -- | Run server runServer :: ServerOpts -> ServerM IO () -> IO () -runServer sopts act = bracket (initLog sopts) (\(_, _, _, x) -> x) $ \(logger', outputStr, listenLog, waitOutput) -> Log.scopeLog logger' (T.pack "hsdev") $ Watcher.withWatcher $ \watcher -> do +runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> Log.scopeLog (sessionLogger slog) (T.pack "hsdev") $ Watcher.withWatcher $ \watcher -> do waitSem <- newQSem 0 db <- DB.newAsync + let + outputStr = Log.writeLog (sessionLogger slog) withCache sopts () $ \cdir -> do outputStr Log.Trace $ "Checking cache version in {}" ~~ cdir ver <- Cache.readVersion $ cdir Cache.versionCache @@ -96,8 +103,8 @@ #if mingw32_HOST_OS mmapPool <- Just <$> createPool "hsdev" #endif - ghcw <- ghcWorker [] (return ()) - ghciw <- ghciWorker + ghcw <- withLog (sessionLogger slog) $ ghcWorker [] (return ()) + ghciw <- withLog (sessionLogger slog) ghciWorker ghcmodw <- ghcModMultiWorker defs <- getDefines let @@ -105,10 +112,7 @@ db (writeCache sopts) (readCache sopts) - outputStr - logger' - listenLog - waitOutput + slog watcher #if mingw32_HOST_OS mmapPool diff --git a/src/HsDev/Server/Commands.hs b/src/HsDev/Server/Commands.hs --- a/src/HsDev/Server/Commands.hs +++ b/src/HsDev/Server/Commands.hs @@ -14,7 +14,6 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Async -import Control.Exception (SomeException) import Control.Lens (set, traverseOf, view, over, Lens', Lens, _1, _2, _Left) import Control.Monad import Control.Monad.CatchIO @@ -24,7 +23,6 @@ import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Map as M import Data.Maybe import Data.String (fromString) import qualified Data.Text as T (pack) @@ -48,6 +46,7 @@ import qualified HsDev.Database.Async as DB import HsDev.Server.Base import HsDev.Server.Types +import HsDev.Error import HsDev.Util import HsDev.Version @@ -72,7 +71,7 @@ asyncAct <- async sendReceive res <- waitCatch asyncAct case res of - Left e -> return $ Error (show e) $ M.fromList [] + Left e -> return $ Error $ OtherError (show e) Right r -> return r where sendReceive = do @@ -100,7 +99,7 @@ parseResponse h resp parseResponse h str = case eitherDecode str of - Left e -> return $ Error e $ M.fromList [("response", toJSON $ fromUtf8 str)] + Left e -> return $ Error $ ResponseError ("can't parse: {}" ~~ e) (fromUtf8 str) Right (Message _ r) -> do Response r' <- unMmap r case r' of @@ -209,7 +208,7 @@ bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do input' <- hGetLineBS stdin case decodeMsg input' of - Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError "invalid command" []) em + Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError $ OtherError "invalid command") em Right m -> do L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m waitResp h @@ -316,7 +315,7 @@ case decodeMessage req' of Left em -> do Log.log Log.Warning $ "Invalid request {}" ~~ fromUtf8 req' - answer $ set msg (Message Nothing $ responseError "Invalid request" ["request" .= fromUtf8 req']) em + answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em Right m -> Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do let @@ -324,7 +323,7 @@ | silent = return () | otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer Log.log Log.Trace $ "{} >> {}" ~~ name ~~ fromUtf8 (encode c) - resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ handleError $ withSession s $ + resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $ processRequest CommandOptions { commandOptionsRoot = cdir, @@ -337,12 +336,7 @@ where handleTimeout :: Int -> IO Result -> IO Result handleTimeout 0 = id - handleTimeout tm = fmap (fromMaybe $ Error "Timeout" M.empty) . timeout tm - - handleError :: IO Result -> IO Result - handleError = flip catch onErr where - onErr :: SomeException -> IO Result - onErr e = return $ Error "Exception" $ M.fromList [("what", toJSON $ show e)] + handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout tm mmap' :: SessionMonad m => Bool -> Response -> m Response #if mingw32_HOST_OS @@ -414,9 +408,9 @@ | Just (MmapFile f) <- parseMaybe parseJSON v = do cts <- runExceptT (fmap L.fromStrict (readMapFile f)) case cts of - Left _ -> return $ responseError "Unable to read map view of file" ["file" .= f] + Left _ -> return $ responseError $ ResponseError "can't read map view of file" f Right r' -> case eitherDecode r' of - Left e' -> return $ responseError "Invalid response" ["response" .= fromUtf8 r', "parser error" .= e'] + Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r') Right r'' -> return r'' #endif unMmap r = return r diff --git a/src/HsDev/Server/Message.hs b/src/HsDev/Server/Message.hs --- a/src/HsDev/Server/Message.hs +++ b/src/HsDev/Server/Message.hs @@ -8,18 +8,14 @@ groupResponses, responsesById ) where -import Control.Arrow (first) import Control.Applicative import Control.Lens (makeLenses) import Control.Monad (join) import Data.Aeson hiding (Error, Result) -import Data.Aeson.Types (Pair) import Data.Either (lefts, isRight) import Data.List (unfoldr) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (unpack) +import HsDev.Types import HsDev.Util ((.::), (.::?), objectUnion) -- | Message with id to link request and response @@ -60,20 +56,16 @@ data Result = Result Value | -- ^ Result - Error String (Map String Value) + Error HsDevError -- ^ Error deriving (Show) instance ToJSON Result where toJSON (Result r) = object ["result" .= r] - toJSON (Error msg rs) = object [ - "error" .= msg, - "details" .= toJSON rs] + toJSON (Error e) = toJSON e instance FromJSON Result where - parseJSON = withObject "result" $ \v -> - (Result <$> v .:: "result") <|> - (Error <$> v .:: "error" <*> v .:: "details") + parseJSON j = (withObject "result" (\v -> (Result <$> v .:: "result")) j) <|> (Error <$> parseJSON j) -- | Part of result list, returns via notification data ResultPart = ResultPart Value @@ -95,8 +87,8 @@ result :: ToJSON a => a -> Response result = Response . Right . Result . toJSON -responseError :: String -> [Pair] -> Response -responseError e ds = Response $ Right $ Error e $ M.fromList $ map (first unpack) ds +responseError :: HsDevError -> Response +responseError = Response . Right . Error resultPart :: ToJSON a => a -> Notification resultPart = Notification . toJSON . ResultPart . toJSON @@ -116,7 +108,7 @@ (ns, cs') = break (isRight . unResponse) cs r = case cs' of (Response (Right r') : _) -> r' - [] -> Error "groupResponses: no result" mempty + [] -> Error $ OtherError "groupResponses: no result" _ -> error "groupResponses: impossible happened" responsesById :: Maybe String -> [Message Response] -> [([Notification], Result)] diff --git a/src/HsDev/Server/Types.hs b/src/HsDev/Server/Types.hs --- a/src/HsDev/Server/Types.hs +++ b/src/HsDev/Server/Types.hs @@ -3,10 +3,10 @@ module HsDev.Server.Types ( ServerMonadBase, - Session(..), SessionMonad(..), askSession, ServerM(..), - CommandOptions(..), CommandError(..), commandErrorMsg, commandErrorDetails, commandError, commandError_, CommandMonad(..), askOptions, ClientM(..), - withSession, serverListen, serverWait, serverUpdateDB, serverWriteCache, serverReadCache, serverExit, commandRoot, commandNotify, commandLink, commandHold, - ServerCommand(..), ConnectionPort(..), ServerOpts(..), ClientOpts(..), serverOptsArgs, Request(..), + SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..), + CommandOptions(..), CommandMonad(..), askOptions, ClientM(..), + withSession, serverListen, serverSetLogRules, serverWait, serverUpdateDB, serverWriteCache, serverReadCache, serverExit, commandRoot, commandNotify, commandLink, commandHold, + ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..), Command(..), AddedContents(..), GhcModCommand(..), @@ -16,7 +16,8 @@ ) where import Control.Applicative -import Control.Lens (each, makeLenses) +import Control.Concurrent.MVar (MVar, swapMVar) +import Control.Lens (each) import Control.Monad.Base import Control.Monad.Catch import Control.Monad.CatchIO @@ -27,6 +28,7 @@ import qualified Data.Aeson.Types as A import qualified Data.ByteString.Lazy.Char8 as L import Data.Default +import Data.Monoid import Data.Foldable (asum) import Options.Applicative import System.Log.Simple hiding (Command) @@ -41,7 +43,7 @@ import HsDev.Server.Message import HsDev.Watcher.Types (Watcher) import HsDev.Tools.GhcMod (OutputMessage, WorkerMap) -import HsDev.Tools.Ghc.Worker (Worker, Ghc) +import HsDev.Tools.Ghc.Worker (Worker, GhcM) import HsDev.Tools.Types (Note) import HsDev.Tools.AutoFix (Correction) import HsDev.Util @@ -50,22 +52,25 @@ import System.Win32.FileMapping.NamePool (Pool) #endif -type ServerMonadBase m = (MonadCatchIO m, MonadBaseControl IO m) +type ServerMonadBase m = (MonadThrow m, MonadCatch m, MonadCatchIO m, MonadBaseControl IO m, Alternative m, MonadPlus m) +data SessionLog = SessionLog { + sessionLogger :: Log, + sessionLogRules :: MVar [String], + sessionListenLog :: IO [String], + sessionLogWait :: IO () } + data Session = Session { sessionDatabase :: DB.Async Database, sessionWriteCache :: Database -> ServerM IO (), sessionReadCache :: (FilePath -> ExceptT String IO Structured) -> ServerM IO (Maybe Database), - sessionLog :: Level -> String -> IO (), - sessionLogger :: Log, - sessionListenLog :: IO [String], - sessionLogWait :: IO (), + sessionLog :: SessionLog, sessionWatcher :: Watcher, #if mingw32_HOST_OS sessionMmapPool :: Maybe Pool, #endif - sessionGhc :: Worker Ghc, - sessionGhci :: Worker Ghc, + sessionGhc :: Worker GhcM, + sessionGhci :: Worker GhcM, sessionGhcMod :: Worker (ReaderT WorkerMap IO), sessionExit :: IO (), sessionWait :: IO (), @@ -77,10 +82,11 @@ askSession :: SessionMonad m => (Session -> a) -> m a askSession f = liftM f getSession -newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a } deriving (Functor, Applicative, Monad, MonadReader Session, MonadIO, MonadTrans, MonadCatchIO, MonadThrow, MonadCatch) +newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadCatchIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch) instance MonadCatchIO m => MonadLog (ServerM m) where - askLog = ServerM $ asks sessionLogger + askLog = ServerM $ asks (sessionLogger . sessionLog) instance ServerMonadBase m => SessionMonad (ServerM m) where getSession = ask @@ -102,60 +108,32 @@ instance Default CommandOptions where def = CommandOptions "." (const $ return ()) (return ()) (return ()) -data CommandError = CommandError { - _commandErrorMsg :: String, - _commandErrorDetails :: [A.Pair] } - -makeLenses ''CommandError - -instance Monoid CommandError where - mempty = CommandError "" [] - mappend (CommandError lmsg lp) (CommandError rmsg rp) = CommandError (lmsg ++ ", " ++ rmsg) (lp ++ rp) - -class (SessionMonad m, MonadError CommandError m, MonadPlus m) => CommandMonad m where +class (SessionMonad m, MonadPlus m) => CommandMonad m where getOptions :: m CommandOptions -commandError :: CommandMonad m => String -> [A.Pair] -> m a -commandError m ds = throwError $ CommandError m ds - -commandError_ :: CommandMonad m => String -> m a -commandError_ m = commandError m [] - askOptions :: CommandMonad m => (CommandOptions -> a) -> m a askOptions f = liftM f getOptions -newtype ClientM m a = ClientM { runClientM :: ServerM (ExceptT CommandError (ReaderT CommandOptions m)) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO, MonadThrow, MonadCatch) +newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadCatchIO, MonadThrow, MonadCatch) instance MonadTrans ClientM where - lift = ClientM . lift . lift . lift + lift = ClientM . lift . lift instance MonadCatchIO m => MonadLog (ClientM m) where askLog = ClientM askLog -instance Monad m => MonadError CommandError (ClientM m) where - throwError = ClientM . lift . throwError - catchError act handler = ClientM $ ServerM $ catchError (runServerM $ runClientM act) (runServerM . runClientM . handler) - -instance Monad m => Alternative (ClientM m) where - empty = ClientM $ ServerM empty - x <|> y = ClientM $ ServerM $ runServerM (runClientM x) <|> runServerM (runClientM y) - -instance Monad m => MonadPlus (ClientM m) where - mzero = ClientM $ ServerM mzero - mplus l r = ClientM $ ServerM $ runServerM (runClientM l) `mplus` runServerM (runClientM r) - instance ServerMonadBase m => SessionMonad (ClientM m) where getSession = ClientM getSession instance ServerMonadBase m => CommandMonad (ClientM m) where - getOptions = ClientM $ lift $ lift ask + getOptions = ClientM $ lift ask instance MonadBase b m => MonadBase b (ClientM m) where liftBase = ClientM . liftBase instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where - type StM (ClientM m) a = StM (ServerM (ExceptT CommandError (ReaderT CommandOptions m))) a + type StM (ClientM m) a = StM (ServerM (ReaderT CommandOptions m)) a liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM)) restoreM = ClientM . restoreM @@ -165,8 +143,14 @@ -- | Listen server's log serverListen :: SessionMonad m => m [String] -serverListen = join . liftM liftIO $ askSession sessionListenLog +serverListen = join . liftM liftIO $ askSession (sessionListenLog . sessionLog) +-- | Set server's log config +serverSetLogRules :: SessionMonad m => [String] -> m [String] +serverSetLogRules rs = do + rvar <- askSession (sessionLogRules . sessionLog) + liftIO $ swapMVar rvar rs + -- | Wait for server serverWait :: SessionMonad m => m () serverWait = join . liftM liftIO $ askSession sessionWait @@ -240,6 +224,10 @@ instance Default ServerOpts where def = ServerOpts def 0 Nothing "use default" Nothing False False +-- | Silent server with no connection, useful for ghci +silentOpts :: ServerOpts +silentOpts = def { serverSilent = True } + -- | Client options data ClientOpts = ClientOpts { clientPort :: ConnectionPort, @@ -351,7 +339,8 @@ -- | Command from client data Command = Ping | - Listen | + Listen (Maybe String) | + SetLogConfig [String] | AddData { addedContents :: [AddedContents] } | Scan { scanProjects :: [FilePath], @@ -511,7 +500,8 @@ instance FromCmd Command where cmdP = subparser $ mconcat [ cmd "ping" "ping server" (pure Ping), - cmd "listen" "listen server log" (pure Listen), + cmd "listen" "listen server log" (Listen <$> optional ruleArg), + cmd "set-log" "set log config rules" (SetLogConfig <$> many (strArgument idm)), cmd "add" "add info to database" (AddData <$> option readJSON idm), cmd "scan" "scan sources" $ Scan <$> many projectArg <*> @@ -622,6 +612,7 @@ pathArg :: Mod OptionFields String -> Parser FilePath projectArg :: Parser String pureFlag :: Parser Bool +ruleArg :: Parser String sandboxArg :: Parser FilePath wideFlag :: Parser Bool @@ -648,12 +639,14 @@ pathArg f = strOption (long "path" <> metavar "path" <> short 'p' <> f) projectArg = strOption (long "project" <> long "proj" <> metavar "project") pureFlag = switch (long "pure" <> help "don't modify actual file, just return result") +ruleArg = strOption (long "config" <> metavar "rule" <> help "set new log rules while in listen command") sandboxArg = strOption (long "sandbox" <> metavar "path" <> help "path to cabal sandbox") wideFlag = switch (long "wide" <> short 'w' <> help "wide mode - complete as if there were no import lists") instance ToJSON Command where toJSON Ping = cmdJson "ping" [] - toJSON Listen = cmdJson "listen" [] + toJSON (Listen r) = cmdJson "listen" ["rule" .= r] + toJSON (SetLogConfig rs) = cmdJson "set-log" ["rules" .= rs] toJSON (AddData cts) = cmdJson "add" ["data" .= cts] toJSON (Scan projs cabal sboxes fs ps contents ghcs docs' infer') = cmdJson "scan" [ "projects" .= projs, @@ -698,7 +691,8 @@ instance FromJSON Command where parseJSON = withObject "command" $ \v -> asum [ guardCmd "ping" v *> pure Ping, - guardCmd "listen" v *> pure Listen, + guardCmd "listen" v *> (Listen <$> v .::? "rule"), + guardCmd "set-log" v *> (SetLogConfig <$> v .:: "rules"), guardCmd "add" v *> (AddData <$> v .:: "data"), guardCmd "scan" v *> (Scan <$> v .::?! "projects" <*> diff --git a/src/HsDev/Stack.hs b/src/HsDev/Stack.hs --- a/src/HsDev/Stack.hs +++ b/src/HsDev/Stack.hs @@ -16,6 +16,7 @@ import Control.Arrow import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.)) import Control.Monad +import Control.Monad.Catch (MonadCatch(..)) import Control.Monad.Trans.Maybe import Control.Monad.IO.Class import Data.Char @@ -29,17 +30,19 @@ import System.Environment import System.FilePath import System.Process +import System.Log.Simple (MonadLog(..)) import qualified GHC import qualified Packages as GHC +import HsDev.Error import HsDev.PackageDb import HsDev.Scan.Browse (withPackages) import HsDev.Util (withCurrentDirectory) -- | Get compiler version -stackCompiler :: MaybeT IO String -stackCompiler = exceptToMaybeT $ do +stackCompiler :: MonadLog m => m String +stackCompiler = do res <- withPackages ["-no-user-package-db"] $ return . map (GHC.packageNameString &&& GHC.packageVersion) . @@ -54,12 +57,13 @@ -- | Get arch for stack stackArch :: String stackArch = T.display buildArch + -- | Invoke stack command, we are trying to get actual stack near current hsdev executable -stack :: [String] -> MaybeT IO String -stack cmd = do +stack :: (MonadLog m, MonadCatch m) => [String] -> m String +stack cmd = hsdevLiftIO $ do curExe <- liftIO getExecutablePath withCurrentDirectory (takeDirectory curExe) $ do - stackExe <- MaybeT $ findExecutable "stack" + stackExe <- liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return comp <- stackCompiler liftIO $ readProcess stackExe (cmd ++ ["--compiler", comp, "--arch", stackArch]) "" @@ -71,7 +75,7 @@ type Paths = Map String FilePath -- | Stack path -path :: Maybe FilePath -> MaybeT IO Paths +path :: (MonadLog m, MonadCatch m) => Maybe FilePath -> m Paths path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where breakPath :: String -> (String, FilePath) breakPath = second (dropWhile isSpace . drop 1) . break (== ':') @@ -81,15 +85,15 @@ pathOf = at -- | Build stack project -build :: [String] -> Maybe FilePath -> MaybeT IO () +build :: (MonadLog m, MonadCatch m) => [String] -> Maybe FilePath -> m () build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg) -- | Build only dependencies -buildDeps :: Maybe FilePath -> MaybeT IO () +buildDeps :: (MonadLog m, MonadCatch m) => Maybe FilePath -> m () buildDeps = build ["--only-dependencies"] -- | Configure project -configure :: Maybe FilePath -> MaybeT IO () +configure :: (MonadLog m, MonadCatch m) => Maybe FilePath -> m () configure = build ["--only-configure"] data StackEnv = StackEnv { @@ -112,12 +116,12 @@ (p ^. pathOf "local-pkg-db") -- | Projects paths -projectEnv :: FilePath -> MaybeT IO StackEnv -projectEnv p = do +projectEnv :: (MonadLog m, MonadCatch m) => FilePath -> m StackEnv +projectEnv p = hsdevLiftIO $ do hasConfig <- liftIO $ doesFileExist yaml' - guard hasConfig + unless hasConfig $ hsdevError $ FileNotFound yaml' paths' <- path (Just yaml') - MaybeT $ return $ getStackEnv paths' + maybe (hsdevError $ ToolError "stack" "can't get paths") return $ getStackEnv paths' where yaml' = p "stack.yaml" diff --git a/src/HsDev/Symbols.hs b/src/HsDev/Symbols.hs --- a/src/HsDev/Symbols.hs +++ b/src/HsDev/Symbols.hs @@ -30,6 +30,9 @@ -- * Other unalias, + -- * Tags + setTag, hasTag, removeTag, dropTags, + -- * Reexportss module HsDev.Symbols.Types, module HsDev.Symbols.Class, @@ -46,6 +49,7 @@ import Data.Maybe (fromMaybe, listToMaybe, catMaybes) import qualified Data.Map as M import Data.Ord (comparing) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T (concat) import System.Directory @@ -227,7 +231,7 @@ locateSourceDir f = runMaybeT $ do file <- liftIO $ canonicalizePath f p <- MaybeT $ locateProject file - proj <- MaybeT $ fmap (either (const Nothing) Just) $ runExceptT $ loadProject p + proj <- lift $ loadProject p MaybeT $ return $ findSourceDir proj file -- | Make `Info` for standalone `Module` @@ -266,3 +270,19 @@ -- | Unalias import name unalias :: Module -> Text -> [Text] unalias m alias = [view importModuleName i | i <- view moduleImports m, view importAs i == Just alias] + +-- | Set tag to `Inspected` +setTag :: Ord t => t -> Inspected i t a -> Inspected i t a +setTag tag = over inspectionTags (S.insert tag) + +-- | Check whether `Inspected` has tag +hasTag :: Ord t => t -> Inspected i t a -> Bool +hasTag tag = has (inspectionTags . ix tag) + +-- | Drop tag from `Inspected` +removeTag :: Ord t => t -> Inspected i t a -> Inspected i t a +removeTag tag = over inspectionTags (S.delete tag) + +-- | Drop all tags +dropTags :: Inspected i t a -> Inspected i t a +dropTags = set inspectionTags S.empty diff --git a/src/HsDev/Symbols/Location.hs b/src/HsDev/Symbols/Location.hs --- a/src/HsDev/Symbols/Location.hs +++ b/src/HsDev/Symbols/Location.hs @@ -34,7 +34,7 @@ import Text.Read (readMaybe) import HsDev.PackageDb -import HsDev.Project +import HsDev.Project.Types import HsDev.Util ((.::), (.::?), (.::?!), objectUnion) -- | Just package name and version without its location diff --git a/src/HsDev/Symbols/Types.hs b/src/HsDev/Symbols/Types.hs --- a/src/HsDev/Symbols/Types.hs +++ b/src/HsDev/Symbols/Types.hs @@ -15,8 +15,9 @@ ModuleDeclaration(..), declarationModuleId, moduleDeclaration, ExportedDeclaration(..), exportedBy, exportedDeclaration, Inspection(..), inspectionAt, inspectionOpts, - Inspected(..), inspection, inspectedId, inspectionResult, - InspectedModule, + Inspected(..), inspection, inspectedId, inspectionTags, inspectionResult, noTags, + ModuleTag(..), + InspectedModule, notInspected, module HsDev.PackageDb, module HsDev.Project, @@ -32,14 +33,19 @@ import Data.Aeson import Data.List (intercalate) import Data.Maybe (fromMaybe) +import Data.Function +import Data.Ord import Data.Text (Text, unpack) import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as S import Data.Time.Clock.POSIX (POSIXTime) import HsDev.PackageDb import HsDev.Project import HsDev.Symbols.Class import HsDev.Symbols.Documented +import HsDev.Types import HsDev.Util (tab, tabs, (.::), (.::?), (.::?!), noNulls) -- | What to export/import for data/class etc @@ -456,6 +462,14 @@ instance Read POSIXTime where readsPrec i = map (first (fromIntegral :: Integer -> POSIXTime)) . readsPrec i +instance Monoid Inspection where + mempty = InspectionNone + mappend InspectionNone r = r + mappend l InspectionNone = l + mappend (InspectionAt ltm lopts) (InspectionAt rtm ropts) + | ltm >= rtm = InspectionAt ltm lopts + | otherwise = InspectionAt rtm ropts + instance ToJSON Inspection where toJSON InspectionNone = object ["inspected" .= False] toJSON (InspectionAt tm fs) = object [ @@ -468,32 +482,60 @@ (InspectionAt <$> (fromInteger <$> v .:: "mtime") <*> (v .:: "flags")) -- | Inspected entity -data Inspected i a = Inspected { +data Inspected i t a = Inspected { _inspection :: Inspection, _inspectedId :: i, - _inspectionResult :: Either String a } - deriving (Eq, Ord) + _inspectionTags :: Set t, + _inspectionResult :: Either HsDevError a } -instance Functor (Inspected i) where +inspectedTup :: Inspected i t a -> (Inspection, i, Set t, Maybe a) +inspectedTup (Inspected insp i tags res) = (insp, i, tags, either (const Nothing) Just res) + +instance (Eq i, Eq t, Eq a) => Eq (Inspected i t a) where + (==) = (==) `on` inspectedTup + +instance (Ord i, Ord t, Ord a) => Ord (Inspected i t a) where + compare = comparing inspectedTup + +instance Functor (Inspected i t) where fmap f insp = insp { _inspectionResult = fmap f (_inspectionResult insp) } -instance Foldable (Inspected i) where +instance Foldable (Inspected i t) where foldMap f = either mempty f . _inspectionResult -instance Traversable (Inspected i) where - traverse f (Inspected insp i r) = Inspected insp i <$> either (pure . Left) (liftA Right . f) r +instance Traversable (Inspected i t) where + traverse f (Inspected insp i ts r) = Inspected insp i ts <$> either (pure . Left) (liftA Right . f) r -instance (NFData i, NFData a) => NFData (Inspected i a) where - rnf (Inspected t i r) = rnf t `seq` rnf i `seq` rnf r +instance (NFData i, NFData t, NFData a) => NFData (Inspected i t a) where + rnf (Inspected t i ts r) = rnf t `seq` rnf i `seq` rnf ts `seq` rnf r +-- | Empty tags +noTags :: Ord t => Set t +noTags = S.empty + +data ModuleTag = InferredTypesTag | RefinedDocsTag deriving (Eq, Ord, Read, Show, Enum, Bounded) + +instance NFData ModuleTag where + rnf InferredTypesTag = () + rnf RefinedDocsTag = () + +instance ToJSON ModuleTag where + toJSON InferredTypesTag = toJSON ("types" :: String) + toJSON RefinedDocsTag = toJSON ("docs" :: String) + +instance FromJSON ModuleTag where + parseJSON = withText "module-tag" $ \txt -> msum [ + guard (txt == "types") >> return InferredTypesTag, + guard (txt == "docs") >> return RefinedDocsTag] + -- | Inspected module -type InspectedModule = Inspected ModuleLocation Module +type InspectedModule = Inspected ModuleLocation ModuleTag Module instance Show InspectedModule where - show (Inspected i mi m) = unlines [either showError show m, "\tinspected: " ++ show i] where - showError :: String -> String - showError e = unlines $ ("\terror: " ++ e) : case mi of + show (Inspected i mi ts m) = unlines [either showError show m, "\tinspected: " ++ show i, "\ttags: " ++ intercalate ", " (map show $ S.toList ts)] where + showError :: HsDevError -> String + showError e = unlines $ ("\terror: " ++ show e) : case mi of FileModule f p -> ["file: " ++ f, "project: " ++ maybe "" (view projectPath) p] InstalledModule c p n -> ["cabal: " ++ show c, "package: " ++ maybe "" show p, "name: " ++ n] ModuleSource src -> ["source: " ++ fromMaybe "" src] @@ -502,13 +544,18 @@ toJSON im = object [ "inspection" .= _inspection im, "location" .= _inspectedId im, + "tags" .= S.toList (_inspectionTags im), either ("error" .=) ("module" .=) (_inspectionResult im)] instance FromJSON InspectedModule where parseJSON = withObject "inspected module" $ \v -> Inspected <$> v .:: "inspection" <*> v .:: "location" <*> + (S.fromList <$> (v .::?! "tags")) <*> ((Left <$> v .:: "error") <|> (Right <$> v .:: "module")) + +notInspected :: ModuleLocation -> InspectedModule +notInspected mloc = Inspected mempty mloc noTags (Left $ NotInspected mloc) instance Symbol Module where symbolName = _moduleName diff --git a/src/HsDev/Tools/Base.hs b/src/HsDev/Tools/Base.hs --- a/src/HsDev/Tools/Base.hs +++ b/src/HsDev/Tools/Base.hs @@ -13,6 +13,7 @@ ) where import Control.Lens (set) +import Control.Monad.Catch (MonadCatch) import Control.Monad.Except import Control.Monad.State import Data.Array (assocs) @@ -22,6 +23,7 @@ import System.Process import Text.Regex.PCRE ((=~), MatchResult(..)) +import HsDev.Error import HsDev.Tools.Types import HsDev.Symbols import HsDev.Util (liftIOErrors) @@ -72,15 +74,14 @@ at_ :: (Int -> Maybe String) -> Int -> String at_ g = fromMaybe "" . g -inspect :: Monad m => ModuleLocation -> ExceptT String m Inspection -> ExceptT String m Module -> ExceptT String m InspectedModule -inspect mloc insp act = lift $ execStateT inspect' (Inspected InspectionNone mloc (Left "not inspected")) where - inspect' = runExceptT $ do - i <- mapExceptT lift insp - modify (set inspection i) - v <- mapExceptT lift act - modify (set inspectionResult (Right v)) - `catchError` - \e -> modify (set inspectionResult (Left e)) +inspect :: MonadCatch m => ModuleLocation -> m Inspection -> m Module -> m InspectedModule +inspect mloc insp act = execStateT inspect' (notInspected mloc) where + inspect' = do + r <- hsdevCatch $ hsdevLiftIO $ do + i <- lift insp + modify (set inspection i) + lift act + modify (set inspectionResult r) type ReadM a = StateT String [] a diff --git a/src/HsDev/Tools/Ghc/Check.hs b/src/HsDev/Tools/Ghc/Check.hs --- a/src/HsDev/Tools/Ghc/Check.hs +++ b/src/HsDev/Tools/Ghc/Check.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, OverloadedStrings #-} module HsDev.Tools.Ghc.Check ( checkFiles, check, checkFile, checkSource, @@ -15,13 +15,16 @@ import Control.Lens (preview, view, each, _Just, (^..)) import Control.Monad.Except +import Control.Monad.Catch (MonadThrow(..)) import Data.Maybe (fromMaybe) import System.FilePath (makeRelative) import System.Directory (doesDirectoryExist) +import System.Log.Simple (MonadLog(..), scope) import GHC hiding (Warning, Module, moduleName) import Control.Concurrent.FiniteChan +import HsDev.Error import HsDev.PackageDb import HsDev.Scan.Browse (browsePackages) import HsDev.Symbols (moduleOpts) @@ -33,8 +36,8 @@ import HsDev.Util (readFileUtf8, ordNub) -- | Check files and collect warnings and errors -checkFiles :: [String] -> PackageDbStack -> [FilePath] -> Maybe Project -> Ghc [Note OutputMessage] -checkFiles opts pdbs files _ = do +checkFiles :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> [FilePath] -> Maybe Project -> m [Note OutputMessage] +checkFiles opts pdbs files _ = scope "check-files" $ do ch <- liftIO newChan withFlags $ do modifyFlags (\fs -> fs { log_action = logToChan ch }) @@ -45,17 +48,17 @@ liftIO $ recalcNotesTabs notes -- | Check module source -check :: [String] -> PackageDbStack -> Module -> Maybe String -> ExceptT String Ghc [Note OutputMessage] -check opts pdbs m msrc = case view moduleLocation m of +check :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> Maybe String -> m [Note OutputMessage] +check opts pdbs m msrc = scope "check" $ case view moduleLocation m of FileModule file proj -> do ch <- liftIO newChan - pkgs <- mapExceptT liftIO $ browsePackages opts pdbs + pkgs <- browsePackages opts pdbs let dir = fromMaybe (sourceModuleRoot (view moduleName m) file) $ preview (_Just . projectPath) proj dirExist <- liftIO $ doesDirectoryExist dir - lift $ withFlags $ (if dirExist then withCurrentDirectory dir else id) $ do + withFlags $ (if dirExist then withCurrentDirectory dir else id) $ do _ <- setCmdOpts $ concat [ ["-Wall"], packageDbStackOpts pdbs, @@ -67,14 +70,14 @@ loadTargets [target] notes <- liftIO $ stopChan ch liftIO $ recalcNotesTabs notes - _ -> throwError "Module is not source" + _ -> scope "check" $ hsdevError $ ModuleNotSource (view moduleLocation m) -- | Check module and collect warnings and errors -checkFile :: [String] -> PackageDbStack -> Module -> ExceptT String Ghc [Note OutputMessage] +checkFile :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> m [Note OutputMessage] checkFile opts pdbs m = check opts pdbs m Nothing -- | Check module and collect warnings and errors -checkSource :: [String] -> PackageDbStack -> Module -> String -> ExceptT String Ghc [Note OutputMessage] +checkSource :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> String -> m [Note OutputMessage] checkSource opts pdbs m src = check opts pdbs m (Just src) -- Recalc tabs for notes diff --git a/src/HsDev/Tools/Ghc/Types.hs b/src/HsDev/Tools/Ghc/Types.hs --- a/src/HsDev/Tools/Ghc/Types.hs +++ b/src/HsDev/Tools/Ghc/Types.hs @@ -9,6 +9,7 @@ import Control.DeepSeq import Control.Lens (over, view, set, each, preview, makeLenses, _Just) import Control.Monad +import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.IO.Class import Data.Aeson import Data.Generics @@ -17,6 +18,7 @@ import Data.String (fromString) import System.Directory import System.FilePath +import System.Log.Simple (MonadLog(..), scope) import GHC hiding (exprType, Module, moduleName) import GHC.SYB.Utils (everythingStaged, Stage(TypeChecker)) @@ -29,6 +31,7 @@ import Pretty import System.Directory.Paths (canonicalize) +import HsDev.Error import HsDev.Scan.Browse (browsePackages) import HsDev.PackageDb import HsDev.Symbols @@ -98,18 +101,18 @@ v .:: "type" -- | Get all types in module -fileTypes :: [String] -> PackageDbStack -> Module -> Maybe String -> ExceptT String Ghc [Note TypedExpr] -fileTypes opts pdbs m msrc = case view moduleLocation m of +fileTypes :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> Maybe String -> m [Note TypedExpr] +fileTypes opts pdbs m msrc = scope "types" $ case view moduleLocation m of FileModule file proj -> do file' <- liftIO $ canonicalize file cts <- maybe (liftIO $ readFileUtf8 file') return msrc - pkgs <- mapExceptT liftIO $ browsePackages opts pdbs + pkgs <- browsePackages opts pdbs let dir = fromMaybe (sourceModuleRoot (view moduleName m) file') $ preview (_Just . projectPath) proj dirExist <- liftIO $ doesDirectoryExist dir - lift $ withFlags $ (if dirExist then withCurrentDirectory dir else id) $ do + withFlags $ (if dirExist then withCurrentDirectory dir else id) $ do _ <- setCmdOpts $ concat [ packageDbStackOpts pdbs, moduleOpts pkgs m, @@ -119,7 +122,7 @@ ts <- moduleTypes file' df <- getSessionDynFlags return $ map (setExpr cts . recalcTabs cts 8 . uncurry (toNote df)) ts - _ -> throwError "Module is not source" + _ -> hsdevError $ ModuleNotSource (view moduleLocation m) where toNote :: DynFlags -> SrcSpan -> Type -> Note String toNote df spn tp = Note { @@ -144,5 +147,5 @@ return $ set (declaration . functionType) (Just $ fromString $ view (note . typedType) tnote) d -- | Infer types in module -inferTypes :: [String] -> PackageDbStack -> Module -> Maybe String -> ExceptT String Ghc Module -inferTypes opts pdbs m msrc = liftM (`setModuleTypes` m) $ fileTypes opts pdbs m msrc +inferTypes :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> Maybe String -> m Module +inferTypes opts pdbs m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes opts pdbs m msrc diff --git a/src/HsDev/Tools/Ghc/Worker.hs b/src/HsDev/Tools/Ghc/Worker.hs --- a/src/HsDev/Tools/Ghc/Worker.hs +++ b/src/HsDev/Tools/Ghc/Worker.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, OverloadedStrings, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module HsDev.Tools.Ghc.Worker ( -- * Workers + GhcM(..), runGhcM, liftGhc, ghcWorker, ghciWorker, -- * Initializers and actions ghcRun, @@ -22,7 +23,9 @@ import Control.Monad import Control.Monad.Catch +import Control.Monad.CatchIO import Control.Monad.Except +import Control.Monad.Reader import Data.Dynamic import Data.Maybe import Data.Time.Clock (getCurrentTime) @@ -30,10 +33,16 @@ import Packages import StringBuffer import System.Directory (getCurrentDirectory, setCurrentDirectory) -import Text.Read +import qualified System.Log.Simple as Log +import System.Log.Simple.Monad (MonadLog(..)) +import Text.Read (readMaybe) +import Text.Format +import Exception (ExceptionMonad(..)) import GHC hiding (Warning, Module, moduleName) +import GhcMonad (Ghc(..)) import GHC.Paths +import DynFlags (HasDynFlags(..)) import Outputable import qualified ErrUtils as E import FastString (unpackFS) @@ -44,36 +53,72 @@ import HsDev.Symbols.Location (Position(..), Region(..), region, ModulePackage, ModuleLocation(..)) import HsDev.Tools.Types +instance MonadThrow Ghc where + throwM = liftIO . throwM + +instance MonadCatch Ghc where + catch = gcatch + +instance MonadCatchIO Ghc where + catch = gcatch + block act = Ghc $ block . unGhc act + unblock act = Ghc $ unblock . unGhc act + +instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where + gcatch act onError = ReaderT $ \v -> gcatch (runReaderT act v) (flip runReaderT v . onError) + gmask f = ReaderT $ \v -> gmask (\h -> flip runReaderT v (f $ \act -> ReaderT (\v' -> h (runReaderT act v')))) + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT r m) where + getDynFlags = lift getDynFlags + +instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where + getSession = lift getSession + setSession = lift . setSession + +newtype GhcM a = GhcM { unGhcM :: ReaderT Log.Log Ghc a } + deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO, MonadThrow, MonadCatch, ExceptionMonad, HasDynFlags, MonadLog, GhcMonad) + +runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a +runGhcM dir act = do + l <- askLog + liftIO $ runGhc dir (runReaderT (unGhcM act) l) + +liftGhc :: Ghc a -> GhcM a +liftGhc = GhcM . lift + -- | Ghc worker. Pass options and initializer action -ghcWorker :: [String] -> Ghc () -> IO (Worker Ghc) -ghcWorker opts initialize = startWorker (runGhc (Just libdir)) ghcInit id where - ghcInit f = ghcRun opts (initialize >> f) +ghcWorker :: MonadLog m => [String] -> GhcM () -> m (Worker GhcM) +ghcWorker opts initialize = do + l <- askLog + liftIO $ startWorker (flip runReaderT l . runGhcM (Just libdir)) (ghcRun opts . (initialize >>)) (Log.scope "ghc") -- | Interpreter worker is worker with @preludeModules@ loaded -ghciWorker :: IO (Worker Ghc) -ghciWorker = ghcWorker [] (importModules preludeModules) +ghciWorker :: MonadLog m => m (Worker GhcM) +ghciWorker = do + l <- askLog + liftIO $ startWorker (flip runReaderT l . runGhcM (Just libdir)) (ghcRun [] . (importModules preludeModules >>)) (Log.scope "ghc") -- | Run ghc -ghcRun :: [String] -> Ghc a -> Ghc a +ghcRun :: GhcMonad m => [String] -> m a -> m a ghcRun opts f = do fs <- getSessionDynFlags defaultCleanupHandler fs $ do (fs', _, _) <- parseDynamicFlags fs (map noLoc opts) let fs'' = fs' { ghcMode = CompManager, - -- ghcLink = LinkInMemory, - -- hscTarget = HscInterpreted } - ghcLink = NoLink, - hscTarget = HscNothing } + ghcLink = LinkInMemory, + hscTarget = HscInterpreted } + -- ghcLink = NoLink, + -- hscTarget = HscNothing } void $ setSessionDynFlags fs'' f -- | Alter @DynFlags@ temporary -withFlags :: Ghc a -> Ghc a +withFlags :: GhcMonad m => m a -> m a withFlags = gbracket getSessionDynFlags (\fs -> setSessionDynFlags fs >> return ()) . const -- | Update @DynFlags@ -modifyFlags :: (DynFlags -> DynFlags) -> Ghc () +modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m () modifyFlags f = do fs <- getSessionDynFlags let @@ -83,25 +128,29 @@ return () -- | Add options without reinit session -addCmdOpts :: [String] -> Ghc () +addCmdOpts :: (MonadLog m, GhcMonad m) => [String] -> m () addCmdOpts opts = do + Log.log Log.Trace $ "setting ghc options: {}" ~~ unwords opts fs <- getSessionDynFlags (fs', _, _) <- parseDynamicFlags fs (map noLoc opts) let fs'' = fs' { ghcMode = CompManager, - ghcLink = NoLink, - hscTarget = HscNothing } + ghcLink = LinkInMemory, + hscTarget = HscInterpreted } + -- ghcLink = NoLink, + -- hscTarget = HscNothing } void $ setSessionDynFlags fs'' -- | Set options after session reinit -setCmdOpts :: [String] -> Ghc () +setCmdOpts :: (MonadLog m, GhcMonad m) => [String] -> m () setCmdOpts opts = do + Log.log Log.Trace $ "restarting ghc session with: {}" ~~ unwords opts initGhcMonad (Just libdir) addCmdOpts opts modifyFlags (\fs -> fs { log_action = logToNull }) -- | Import some modules -importModules :: [String] -> Ghc () +importModules :: GhcMonad m => [String] -> m () importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl -- | Default interpreter modules @@ -109,16 +158,16 @@ preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"] -- | Evaluate expression -evaluate :: String -> Ghc String -evaluate expr = liftM fromDynamic (dynCompileExpr $ "show (" ++ expr ++ ")") >>= +evaluate :: GhcMonad m => String -> m String +evaluate expr = liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr) >>= maybe (fail "evaluate fail") return -- | Clear loaded targets -clearTargets :: Ghc () +clearTargets :: GhcMonad m => m () clearTargets = loadTargets [] -- | Make target with its source code optional -makeTarget :: String -> Maybe String -> Ghc Target +makeTarget :: GhcMonad m => String -> Maybe String -> m Target makeTarget name Nothing = guessTarget name Nothing makeTarget name (Just cts) = do t <- guessTarget name Nothing @@ -126,11 +175,11 @@ return t { targetContents = Just (stringToStringBuffer cts, tm) } -- | Load all targets -loadTargets :: [Target] -> Ghc () +loadTargets :: GhcMonad m => [Target] -> m () loadTargets ts = setTargets ts >> load LoadAllTargets >> return () -- | Get list of installed packages -listPackages :: Ghc [ModulePackage] +listPackages :: GhcMonad m => m [ModulePackage] listPackages = liftM (mapMaybe readPackage . fromMaybe [] . pkgDatabase) getSessionDynFlags readPackage :: PackageConfig -> Maybe ModulePackage @@ -142,7 +191,7 @@ spanRegion _ = Position 0 0 `region` Position 0 0 -- | Set current directory and restore it after action -withCurrentDirectory :: FilePath -> Ghc a -> Ghc a +withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ const (liftIO (setCurrentDirectory dir) >> act) @@ -174,9 +223,3 @@ logToNull _ _ _ _ _ = return () -- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@ - -instance MonadThrow Ghc where - throwM = liftIO . throwM - -instance MonadCatch Ghc where - catch = gcatch diff --git a/src/HsDev/Tools/GhcMod.hs b/src/HsDev/Tools/GhcMod.hs --- a/src/HsDev/Tools/GhcMod.hs +++ b/src/HsDev/Tools/GhcMod.hs @@ -32,7 +32,7 @@ import Control.Arrow import Control.Concurrent import Control.DeepSeq -import Control.Exception (SomeException(..)) +import Control.Exception (SomeException(..), displayException) import Control.Lens (view, preview, _Just, over) import Control.Monad.Except import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) @@ -46,6 +46,7 @@ import Exception (gcatch) import System.Directory import System.FilePath (normalise) +import System.Log.Simple (withNoLog) import Text.Read (readMaybe) import Language.Haskell.GhcMod (GhcModT, withOptions) @@ -54,6 +55,7 @@ import qualified Language.Haskell.GhcMod.Types as GhcMod import Control.Concurrent.Worker +import HsDev.Error import HsDev.PackageDb import HsDev.Project import HsDev.Sandbox (searchPackageDbStack) @@ -259,7 +261,7 @@ locateGhcModEnv :: FilePath -> IO (Either Project PackageDbStack) locateGhcModEnv f = do mproj <- locateProject f - maybe (liftM Right $ searchPackageDbStack f) (return . Left) mproj + maybe (liftM Right $ withNoLog $ searchPackageDbStack f) (return . Left) mproj ghcModEnvPath :: FilePath -> Either Project PackageDbStack -> FilePath ghcModEnvPath defaultPath = either (view projectPath) (fromMaybe defaultPath . preview packageDb . topPackageDb) @@ -308,11 +310,11 @@ t <- pushTask w act return (M.insert envPath' w wmap, t) -waitMultiGhcMod :: Worker (ReaderT WorkerMap IO) -> FilePath -> GhcModT IO a -> ExceptT String IO a +waitMultiGhcMod :: Worker (ReaderT WorkerMap IO) -> FilePath -> GhcModT IO a -> IO a waitMultiGhcMod w f = liftIO . pushTask w . dispatch f >=> asExceptT . waitCatch >=> asExceptT . waitCatch where - asExceptT :: Monad m => m (Either SomeException a) -> ExceptT String m a - asExceptT = ExceptT . liftM (left (\(SomeException e) -> show e)) + asExceptT :: IO (Either SomeException a) -> IO a + asExceptT act = act >>= either (hsdevError . ToolError "ghc-mod" . displayException) return diff --git a/src/HsDev/Types.hs b/src/HsDev/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsDev/Types.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HsDev.Types ( + HsDevError(..) + ) where + +import Control.Exception +import Control.DeepSeq (NFData(..)) +import Data.Aeson +import Data.Aeson.Types (Pair, Parser) +import Data.Typeable +import Text.Format + +import HsDev.Symbols.Location + +-- | hsdev exception type +data HsDevError = + ModuleNotSource ModuleLocation | + BrowseNoModuleInfo String | + FileNotFound FilePath | + ToolNotFound String | + ProjectNotFound String | + ToolError String String | + NotInspected ModuleLocation | + InspectError String | + InspectCabalError FilePath String | + IOFailed String | + GhcError String | + RequestError String String | + ResponseError String String | + OtherError String + deriving (Typeable) + +instance NFData HsDevError where + rnf (ModuleNotSource mloc) = rnf mloc + rnf (BrowseNoModuleInfo m) = rnf m + rnf (FileNotFound f) = rnf f + rnf (ToolNotFound t) = rnf t + rnf (ProjectNotFound p) = rnf p + rnf (ToolError t e) = rnf t `seq` rnf e + rnf (NotInspected mloc) = rnf mloc + rnf (InspectError e) = rnf e + rnf (InspectCabalError c e) = rnf c `seq` rnf e + rnf (IOFailed e) = rnf e + rnf (GhcError e) = rnf e + rnf (RequestError e r) = rnf e `seq` rnf r + rnf (ResponseError e r) = rnf e `seq` rnf r + rnf (OtherError e) = rnf e + +instance Show HsDevError where + show (ModuleNotSource mloc) = format "module is not source: {}" ~~ show mloc + show (BrowseNoModuleInfo m) = format "can't find module info for {}" ~~ m + show (FileNotFound f) = format "file '{}' not found" ~~ f + show (ToolNotFound t) = format "tool '{}' not found" ~~ t + show (ProjectNotFound p) = format "project '{}' not found" ~~ p + show (ToolError t e) = format "tool '{}' failed: {}" ~~ t ~~ e + show (NotInspected mloc) = "module not inspected: {}" ~~ show mloc + show (InspectError e) = format "failed to inspect: {}" ~~ e + show (InspectCabalError c e) = format "failed to inspect cabal {}: {}" ~~ c ~~ e + show (IOFailed e) = format "io exception: {}" ~~ e + show (GhcError e) = format "ghc exception: {}" ~~ e + show (RequestError e r) = format "request error: {}, request: {}" ~~ e ~~ r + show (ResponseError e r) = format "response error: {}, response: {}" ~~ e ~~ r + show (OtherError e) = e + +instance FormatBuild HsDevError where + +jsonErr :: String -> [Pair] -> Value +jsonErr e = object . (("error" .= e) :) + +instance ToJSON HsDevError where + toJSON (ModuleNotSource mloc) = jsonErr "module is not source" ["module" .= mloc] + toJSON (BrowseNoModuleInfo m) = jsonErr "no module info" ["module" .= m] + toJSON (FileNotFound f) = jsonErr "file not found" ["file" .= f] + toJSON (ToolNotFound t) = jsonErr "tool not found" ["tool" .= t] + toJSON (ProjectNotFound p) = jsonErr "project not found" ["project" .= p] + toJSON (ToolError t e) = jsonErr "tool error" ["tool" .= t, "msg" .= e] + toJSON (NotInspected mloc) = jsonErr "module not inspected" ["module" .= mloc] + toJSON (InspectError e) = jsonErr "inspect error" ["msg" .= e] + toJSON (InspectCabalError c e) = jsonErr "inspect cabal error" ["cabal" .= c, "msg" .= e] + toJSON (IOFailed e) = jsonErr "io error" ["msg" .= e] + toJSON (GhcError e) = jsonErr "ghc error" ["msg" .= e] + toJSON (RequestError e r) = jsonErr "request error" ["msg" .= e, "request" .= r] + toJSON (ResponseError e r) = jsonErr "response error" ["msg" .= e, "response" .= r] + toJSON (OtherError e) = jsonErr "other error" ["msg" .= e] + +instance FromJSON HsDevError where + parseJSON = withObject "hsdev-error" $ \v -> do + err <- v .: "error" :: Parser String + case err of + "module is not source" -> ModuleNotSource <$> v .: "module" + "no module info" -> BrowseNoModuleInfo <$> v .: "module" + "file not found" -> FileNotFound <$> v .: "file" + "tool not found" -> ToolNotFound <$> v .: "tool" + "project not found" -> ProjectNotFound <$> v .: "project" + "tool error" -> ToolError <$> v .: "tool" <*> v .: "msg" + "module not inspected" -> NotInspected <$> v .: "module" + "inspect error" -> InspectError <$> v .: "msg" + "inspect cabal error" -> InspectCabalError <$> v .: "cabal" <*> v .: "msg" + "io error" -> IOFailed <$> v .: "msg" + "ghc error" -> GhcError <$> v .: "msg" + "request error" -> RequestError <$> v .: "msg" <*> v .: "request" + "response error" -> ResponseError <$> v .: "msg" <*> v .: "response" + "other error" -> OtherError <$> v .: "msg" + _ -> fail "invalid error" + +instance Exception HsDevError diff --git a/tools/Tool.hs b/tools/Tool.hs --- a/tools/Tool.hs +++ b/tools/Tool.hs @@ -2,8 +2,11 @@ module Tool ( -- * Tool - ToolM, toolMain, printExceptT, printResult, + ToolM, toolMain, printExceptT, printResult, runToolClient, + ClientM, + + toJSON, Value, module Options.Applicative, module HsDev.Util ) where @@ -13,10 +16,13 @@ import Control.Monad (liftM) import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L (putStrLn) +import Data.Default import Options.Applicative import System.Environment import System.IO +import HsDev.Client.Commands +import HsDev.Server.Base import HsDev.Tools.Base (ToolM) import HsDev.Util (cmd, parseArgs) @@ -34,3 +40,7 @@ printResult :: (ToJSON a, MonadIO m) => m a -> m () printResult act = act >>= liftIO . L.putStrLn . encode + +runToolClient :: ToJSON a => ClientM IO a -> IO () +runToolClient act = runServer silentOpts $ + runClient def act >>= liftIO . L.putStrLn . encode diff --git a/tools/hsinspect.hs b/tools/hsinspect.hs --- a/tools/hsinspect.hs +++ b/tools/hsinspect.hs @@ -6,15 +6,14 @@ import Control.Monad (liftM, (>=>)) import Control.Monad.IO.Class -import Control.Monad.Except (ExceptT(..), runExceptT) -import Data.Aeson (toJSON) import System.Directory (canonicalizePath) import System.FilePath (takeExtension) +import HsDev.Error +import HsDev.Inspect (inspectContents, inspectDocs, getDefines) import HsDev.PackageDb import HsDev.Project (readProject) import HsDev.Scan (scanModule, scanModify) -import HsDev.Inspect (inspectContents, inspectDocs, getDefines) import HsDev.Symbols.Location (ModuleLocation(..)) import HsDev.Tools.Ghc.Types (inferTypes) import HsDev.Tools.Ghc.Worker @@ -29,23 +28,24 @@ many (strOption (metavar "GHC_OPT" <> long "ghc" <> short 'g' <> help "options to pass to GHC")) main :: IO () -main = toolMain "hsinspect" "haskell inspect" opts (printExceptT . printResult . inspect') where +main = toolMain "hsinspect" "haskell inspect" opts (runToolClient . inspect') where + inspect' :: Opts -> ClientM IO Value inspect' (Opts Nothing ghcs) = do cts <- liftIO getContents defs <- liftIO getDefines - liftM toJSON $ inspectContents "stdin" defs ghcs cts + liftM toJSON $ liftIO $ hsdevLift $ inspectContents "stdin" defs ghcs cts inspect' (Opts (Just fname@(takeExtension -> ".hs")) ghcs) = do fname' <- liftIO $ canonicalizePath fname defs <- liftIO getDefines im <- scanModule defs ghcs (FileModule fname' Nothing) Nothing - ghc <- liftIO $ ghcWorker ghcs (return ()) + ghc <- ghcWorker ghcs (return ()) let scanAdditional = - scanModify' (\opts' _ -> inspectDocs opts') >=> - scanModify' (\opts' pdbs m -> ExceptT (inWorker ghc (runExceptT $ inferTypes opts' pdbs m Nothing))) + scanModify' (\opts' _ -> liftIO . inspectDocs opts') >=> + scanModify' (\opts' pdbs m -> liftIO (inWorker ghc (inferTypes opts' pdbs m Nothing))) toJSON <$> scanAdditional im inspect' (Opts (Just fcabal@(takeExtension -> ".cabal")) _) = do fcabal' <- liftIO $ canonicalizePath fcabal - toJSON <$> readProject fcabal' + toJSON <$> liftIO (readProject fcabal') inspect' (Opts (Just mname) ghcs) = toJSON <$> scanModule [] ghcs (InstalledModule UserDb Nothing mname) Nothing scanModify' f im = scanModify f im <|> return im