hsdev 0.1.4.2 → 0.1.4.3
raw patch · 6 files changed
+114/−74 lines, 6 filesdep ~ghc-mod
Dependency ranges changed: ghc-mod
Files
- hsdev.cabal +2/−2
- src/HsDev/Client/Commands.hs +52/−17
- src/HsDev/Database/Update.hs +21/−17
- src/HsDev/Inspect.hs +23/−24
- src/HsDev/Scan.hs +14/−12
- tools/hsinspect.hs +2/−2
hsdev.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hsdev -version: 0.1.4.2 +version: 0.1.4.3 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. @@ -106,7 +106,7 @@ filepath >= 1.4.0, fsnotify >= 0.2.1, ghc >= 7.10.0 && < 7.11.0, - ghc-mod >= 5.2.1.3, + ghc-mod >= 5.3.0.0, ghc-paths >= 0.1.0, ghc-syb-utils >= 0.2.3, haddock-api >= 2.16.0 && < 2.17.0,
src/HsDev/Client/Commands.hs view
@@ -60,6 +60,7 @@ manyReq $ projectArg `desc` "project path or .cabal", manyReq $ fileArg `desc` "source file", manyReq $ pathArg `desc` "directory to scan for files and projects", + dataArg `desc` "files contents in format {<path>:<contents>, ...}", ghcOpts, docsFlag, inferFlag]) "scan sources" scan', @@ -69,10 +70,10 @@ manyReq $ moduleArg `desc` "module name"] "scan docs" docs', - cmd' "infer" [] [ + cmd' "infer" [] ([ manyReq $ projectArg `desc` "project path or .cabal", manyReq $ fileArg `desc` "source file", - manyReq $ moduleArg `desc` "module name"] + manyReq $ moduleArg `desc` "module name"] ++ autoScanOpts) "infer types for specified modules" infer', cmdList' "remove" [] (sandboxes ++ [ @@ -101,7 +102,7 @@ fileArg `desc` "source file", moduleArg, localsArg, packageArg, depsArg, noLastArg, packageVersionArg, - sourced, standaloned]) + sourced, standaloned] ++ autoScanOpts) "get symbol info" symbol', cmd' "module" [] (sandboxes ++ [ @@ -109,19 +110,19 @@ packageArg, depsArg, noLastArg, packageVersionArg, projectArg `desc` "module project", fileArg `desc` "module source file", - sourced]) + sourced] ++ autoScanOpts) "get module info" modul', cmd' "resolve" [] (sandboxes ++ [ moduleArg, localsArg, projectArg `desc` "module project", fileArg `desc` "module source file", - exportsArg]) + exportsArg] ++ autoScanOpts) "resolve module scope (or exports)" resolve', - cmd' "project" [] [ + cmd' "project" [] ([ projectArg `desc` "project path or name", - pathArg `desc` "locate project in parent of this path"] + pathArg `desc` "locate project in parent of this path"] ++ autoScanOpts) "get project info" project', cmd' "sandbox" [] [ @@ -137,16 +138,16 @@ -- Tool commands cmdList' "hayoo" ["query"] hayooArgs "find declarations online via Hayoo" hayoo', cmdList' "cabal list" ["packages..."] [] "list cabal packages" cabalList', - cmdList' "lint" ["files..."] [dataArg] "lint source files or file contents" lint', - cmdList' "check" ["files..."] [dataArg, sandboxArg, ghcOpts] "check source files or file contents" check', - cmdList' "check-lint" ["files..."] [dataArg, sandboxArg, ghcOpts] "check and lint source files or file contents" checkLint', - cmdList' "types" ["file"] [dataArg, sandboxArg, ghcOpts] "get types for file expressions" types', + cmdList' "lint" ["files..."] ([dataArg] ++ autoScanOpts) "lint source files or file contents" lint', + cmdList' "check" ["files..."] ([dataArg, sandboxArg, ghcOpts] ++ autoScanOpts) "check source files or file contents" check', + cmdList' "check-lint" ["files..."] ([dataArg, sandboxArg, ghcOpts] ++ autoScanOpts) "check and lint source files or file contents" checkLint', + cmdList' "types" ["file"] ([dataArg, sandboxArg, ghcOpts] ++ autoScanOpts) "get types for file expressions" types', cmdList' "ghc-mod lang" [] [] "get LANGUAGE pragmas" ghcmodLang', cmdList' "ghc-mod flags" [] [] "get OPTIONS_GHC pragmas" ghcmodFlags', cmdList' "ghc-mod type" ["line", "column"] (ctx ++ [ghcOpts]) "infer type with 'ghc-mod type'" ghcmodType', - cmdList' "ghc-mod check" ["files..."] [sandboxArg, ghcOpts] "check source files" ghcmodCheck', - cmdList' "ghc-mod lint" ["files..."] [hlintOpts] "lint source files" ghcmodLint', - cmdList' "ghc-mod check-lint" ["files..."] [sandboxArg, ghcOpts, hlintOpts] "check & lint source files" ghcmodCheckLint', + cmdList' "ghc-mod check" ["files..."] ([sandboxArg, ghcOpts] ++ autoScanOpts) "check source files" ghcmodCheck', + cmdList' "ghc-mod lint" ["files..."] ([hlintOpts] ++ autoScanOpts) "lint source files" ghcmodLint', + cmdList' "ghc-mod check-lint" ["files..."] ([sandboxArg, ghcOpts, hlintOpts] ++ autoScanOpts) "check & lint source files" ghcmodCheckLint', -- Autofix cmd' "autofix show" [] [dataArg] "generate corrections for check & lint messages" autofixShow', cmd' "autofix fix" [] [dataArg, restMsgsArg, pureArg] "fix errors and return rest corrections with updated regions" autofixFix', @@ -189,6 +190,8 @@ -- Command arguments and flags allFlag d = flag "all" `short` ['a'] `desc` d + autoScanFlag = flag "autoscan" `short` ['s'] `desc` "automatically scan related files/projects" + autoScanOpts = [autoScanFlag, ghcOpts] cacheDir = req "cache-dir" "path" `desc` "cache path" cacheFile = req "cache-file" "path" `desc` "cache file" ctx = [fileArg `desc` "source file", sandboxArg] @@ -276,7 +279,18 @@ scan' :: [String] -> Opts String -> CommandActionT () scan' _ as copts = do cabals <- getSandboxes copts as + let + getData :: String -> CommandM [(FilePath, String)] + getData d = + either + (\err -> commandError "Unable to decode data" [ + "why" .= err, + "data" .= d]) + (return . M.toList) . + eitherDecode . toUtf8 $ d + ctsFiles <- traverse getData $ arg "data" as updateProcess copts as $ concat [ + map (\(f, cts) -> Update.scanFileContents (listArg "ghc" as) f (Just cts)) (fromMaybe [] ctsFiles), concatMap (\(n, f) -> [findPath copts v >>= f (listArg "ghc" as) | v <- listArg n as]) [ ("project", Update.scanProject), ("file", Update.scanFile), @@ -302,6 +316,7 @@ infer' _ as copts = do files <- traverse (findPath copts) $ listArg "file" as projects <- traverse (findProject copts) $ listArg "project" as + autoScan as copts files projects dbval <- getDb copts let filters = anyOf $ @@ -386,6 +401,7 @@ dbval <- liftM (localsDatabase as) $ getDb copts proj <- traverse (findProject copts) $ arg "project" as file <- traverse (findPath copts) $ arg "file" as + autoScan as copts (maybeToList file) (maybeToList proj) deps <- traverse (findDep copts) $ arg "deps" as cabal <- getCabal_ copts as let @@ -414,6 +430,7 @@ proj <- traverse (findProject copts) $ arg "project" as cabal <- getCabal_ copts as file' <- mapExceptT (fmap $ left commandStrMsg) $ traverse (findPath copts) $ arg "file" as + autoScan as copts (maybeToList file') (maybeToList proj) deps <- traverse (findDep copts) $ arg "deps" as let filters = allOf $ catMaybes [ @@ -441,6 +458,7 @@ proj <- traverse (findProject copts) $ arg "project" as cabal <- getCabal copts as file' <- mapExceptT (fmap $ left commandStrMsg) $ traverse (findPath copts) $ arg "file" as + autoScan as copts (maybeToList file') (maybeToList proj) let filters = allOf $ catMaybes [ fmap inProject proj, @@ -462,9 +480,11 @@ -- | Get project info project' :: [String] -> Opts String -> CommandActionT Project project' _ as copts = do - proj <- runMaybeT $ msum $ map MaybeT [ - traverse (findProject copts) $ arg "project" as, - liftM join $ traverse (liftIO . searchProject) $ arg "path" as] + proj <- runMaybeT $ do + p <- msum $ map MaybeT [ + traverse (findProject copts) $ arg "project" as, + liftM join $ traverse (liftIO . searchProject) $ arg "path" as] + lift $ if flagSet "autoscan" as then mapCommandErrorStr (loadProject p) else return p maybe (commandError "Specify project name, .cabal file or search directory" []) return proj -- | Locate sandbox @@ -534,6 +554,7 @@ lint' files as copts = case arg "data" as of Nothing -> do files' <- mapM (findPath copts) files + autoScan as copts files' [] mapCommandErrorStr $ liftM concat $ mapM HLint.hlintFile files' Just src -> do src' <- either @@ -551,6 +572,7 @@ check' files as copts = case arg "data" as of Nothing -> do files' <- mapM (findPath copts) files + autoScan as copts files' [] db <- getDb copts cabal <- getCabal copts as liftM concat $ forM files' $ \file' -> do @@ -588,6 +610,7 @@ types' :: [String] -> Opts String -> CommandActionT [Tools.Note Types.TypedExpr] types' [file] as copts = do file' <- findPath copts file + autoScan as copts [file'] [] db <- getDb copts cabal <- getCabal copts as let @@ -632,6 +655,7 @@ ghcmodCheck' [] _ _ = commandError "Specify at least one file" [] ghcmodCheck' files as copts = do files' <- mapM (findPath copts) files + autoScan as copts files' [] mproj <- (listToMaybe . catMaybes) <$> liftIO (mapM locateProject files') cabal <- getCabal copts as dbval <- getDb copts @@ -645,6 +669,7 @@ ghcmodLint' [] _ _ = commandError "Specify at least one file to hlint" [] ghcmodLint' files as copts = do files' <- mapM (findPath copts) files + autoScan as copts files' [] mapCommandErrorStr $ liftM concat $ forM files' $ \file' -> GhcMod.waitMultiGhcMod (commandGhcMod copts) file' $ GhcMod.lint (listArg "hlint" as) file' @@ -654,6 +679,7 @@ ghcmodCheckLint' [] _ _ = commandError "Specify at least one file" [] ghcmodCheckLint' files as copts = do files' <- mapM (findPath copts) files + autoScan as copts files' [] mproj <- (listToMaybe . catMaybes) <$> liftIO (mapM locateProject files') cabal <- getCabal copts as dbval <- getDb copts @@ -773,6 +799,15 @@ commandStrMsg :: String -> CommandError commandStrMsg m = CommandError m [] + +-- | Automatically scan files and projects +autoScan :: Opts String -> CommandOptions -> [FilePath] -> [Project] -> CommandM () +autoScan as copts srcs projs + | flagSet "autoscan" as = updateProcess copts as $ + concatMap (\(n, f) -> [findPath copts v >>= f (listArg "ghc" as) | v <- n]) [ + (srcs, Update.scanFile), + (map (view projectCabal) projs, Update.scanProject)] + | otherwise = return () -- | Check positional args count checkPosArgs :: Cmd a -> Cmd a
src/HsDev/Database/Update.hs view
@@ -11,7 +11,7 @@ postStatus, waiter, updater, loadCache, getCache, runTask, runTasks, readDB, - scanModule, scanModules, scanFile, scanCabal, scanProjectFile, scanProject, scanDirectory, + scanModule, scanModules, scanFile, scanFileContents, scanCabal, scanProjectFile, scanProject, scanDirectory, scanDocs, inferModTypes, scan, updateEvent, processEvent, @@ -26,7 +26,7 @@ import Control.Concurrent.Lifted (fork) import Control.DeepSeq -import Control.Lens (preview, _Just, view) +import Control.Lens (preview, _Just, view, _1, mapMOf_, each, (^..)) import Control.Monad.Catch import Control.Monad.CatchIO import Control.Monad.Except @@ -191,9 +191,9 @@ readDB = asks database >>= liftIO . readAsync -- | Scan module -scanModule :: (MonadIO m, MonadCatch m) => [String] -> ModuleLocation -> ExceptT String (UpdateDB m) () -scanModule opts mloc = runTask "scanning" (subject mloc ["module" .= mloc]) $ do - im <- liftExceptT $ S.scanModule opts mloc +scanModule :: (MonadIO m, MonadCatch m) => [String] -> ModuleLocation -> Maybe String -> ExceptT String (UpdateDB m) () +scanModule opts mloc mcts = runTask "scanning" (subject mloc ["module" .= mloc]) $ do + im <- liftExceptT $ S.scanModule opts mloc mcts updater $ return $ fromModule im _ <- ExceptT $ return $ view inspectionResult im return () @@ -202,28 +202,32 @@ scanModules :: (MonadIO m, MonadCatch m) => [String] -> [S.ModuleToScan] -> ExceptT String (UpdateDB m) () scanModules opts ms = runTasks $ [scanProjectFile opts p >> return () | p <- ps] ++ - [scanModule (opts ++ snd m) (fst m) | m <- ms] + [scanModule (opts ++ mopts) m mcts | (m, mopts, mcts) <- ms] where - ps = ordNub $ mapMaybe (toProj . fst) ms + ps = ordNub $ mapMaybe (toProj . view _1) ms toProj (FileModule _ p) = fmap (view projectCabal) p toProj _ = Nothing -- | Scan source file scanFile :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> ExceptT String (UpdateDB m) () -scanFile opts fpath = do +scanFile opts fpath = scanFileContents opts fpath Nothing + +-- | Scan source file with contents +scanFileContents :: (MonadIO m, MonadCatch m) => [String] -> FilePath -> Maybe String -> ExceptT String (UpdateDB m) () +scanFileContents opts fpath mcts = do dbval <- readDB fpath' <- liftEIO $ canonicalizePath fpath ex <- liftEIO $ doesFileExist fpath' - mlocs <- case ex of - True -> do + mlocs <- if ex + then do mloc <- case lookupFile fpath' dbval of Just m -> return $ view moduleLocation m Nothing -> do mproj <- liftEIO $ locateProject fpath' return $ FileModule fpath' mproj - return [(mloc, [])] - False -> return [] - mapM_ watch [(`watchModule` m) | (m, _) <- mlocs] + return [(mloc, [], mcts)] + else return [] + mapMOf_ (each . _1) (watch . flip watchModule) mlocs scan (Cache.loadFiles (== fpath')) (filterDB (inFile fpath') (const False) . standaloneDB) @@ -239,9 +243,9 @@ watch (\w -> watchSandbox w cabalSandbox opts) mlocs <- runTask "getting list of cabal modules" [] $ liftExceptT $ listModules opts cabalSandbox - scan (Cache.loadCabal cabalSandbox) (cabalDB cabalSandbox) (zip mlocs $ repeat []) opts $ \mlocs' -> do + scan (Cache.loadCabal cabalSandbox) (cabalDB cabalSandbox) ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do ms <- runTask "loading modules" [] $ - liftExceptT $ browseModules opts cabalSandbox (map fst mlocs') + liftExceptT $ browseModules opts cabalSandbox (mlocs' ^.. each . _1) docs <- runTask "loading docs" [] $ liftExceptT $ hdocsCabal cabalSandbox opts updater $ return $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms @@ -270,7 +274,7 @@ liftExceptT $ S.enumDirectory dir runTasks [scanProject opts (view projectCabal p) | (p, _) <- projSrcs] runTasks $ map (scanCabal opts) sboxes - mapM_ watch [(`watchModule` m) | (m, _) <- standSrcs] + mapMOf_ (each . _1) (watch . flip watchModule) standSrcs scan (Cache.loadFiles (dir `isParent`)) (filterDB inDir (const False) . standaloneDB) standSrcs opts $ scanModules opts where inDir = maybe False (dir `isParent`) . preview (moduleIdLocation . moduleFile) @@ -319,7 +323,7 @@ scan cache' part' mlocs opts act = do dbval <- getCache cache' part' let - obsolete = filterDB (\m -> view moduleIdLocation m `notElem` map fst mlocs) (const False) dbval + obsolete = filterDB (\m -> view moduleIdLocation m `notElem` (mlocs ^.. each . _1)) (const False) dbval changed <- runTask "getting list of changed modules" [] $ liftExceptT $ S.changedModules dbval opts mlocs runTask "removing obsolete modules" ["modules" .= map (view moduleLocation) (allModules obsolete)] $ cleaner $ return obsolete act changed
src/HsDev/Inspect.hs view
@@ -22,12 +22,12 @@ import Data.Function (on) import Data.List import Data.Map (Map)-import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe)+import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe, isJust) import Data.Ord (comparing) import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T (unpack)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, getPOSIXTime) import qualified Data.Map as M import qualified Language.Haskell.Exts as H import qualified System.Directory as Dir@@ -42,7 +42,7 @@ -- | Analize source contents analyzeModule :: [String] -> Maybe FilePath -> String -> Either String Module-analyzeModule exts file source = case H.parseFileContentsWithMode pmode source' of+analyzeModule exts file source = case H.parseFileContentsWithMode (parseMode file exts) source' of H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason H.ParseOk (H.Module _ (H.ModuleName mname) _ _ mexports imports declarations) -> Right Module { _moduleName = fromString mname,@@ -52,13 +52,6 @@ _moduleImports = map getImport imports, _moduleDeclarations = sortDeclarations $ getDecls declarations } where- pmode :: H.ParseMode- pmode = H.defaultParseMode {- H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,- H.baseLanguage = H.Haskell2010,- H.extensions = H.glasgowExts ++ map H.parseExtension exts,- H.fixities = Just H.baseFixities }- -- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces source' = map untab source untab '\t' = ' '@@ -68,7 +61,7 @@ analyzeModule_ :: [String] -> Maybe FilePath -> String -> Either String Module analyzeModule_ exts file source = do mname <- parseModuleName source'- return $ Module {+ return Module { _moduleName = fromString mname, _moduleDocs = Nothing, _moduleLocation = ModuleSource Nothing,@@ -91,25 +84,25 @@ g 1 parseDecl' :: Int -> String -> Maybe H.Decl- parseDecl' offset cts = fmap (transformBi addOffset) $ case H.parseDeclWithMode pmode cts of+ parseDecl' offset cts = fmap (transformBi addOffset) $ case H.parseDeclWithMode (parseMode file exts) cts of H.ParseFailed _ _ -> Nothing H.ParseOk decl' -> Just decl' where addOffset :: H.SrcLoc -> H.SrcLoc addOffset src = src { H.srcLine = H.srcLine src + offset } - pmode :: H.ParseMode- pmode = H.defaultParseMode {- H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,- H.baseLanguage = H.Haskell2010,- H.extensions = H.glasgowExts ++ map H.parseExtension exts,- H.fixities = Just H.baseFixities }- -- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces source' = map untab source untab '\t' = ' ' untab ch = ch +parseMode :: Maybe FilePath -> [String] -> H.ParseMode+parseMode file exts = H.defaultParseMode {+ H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,+ H.baseLanguage = H.Haskell2010,+ H.extensions = H.glasgowExts ++ map H.parseExtension exts,+ H.fixities = Just H.baseFixities }+ -- | Get exports getExports :: H.ExportSpec -> [Export] getExports (H.EModuleContents (H.ModuleName m)) = [ExportModule $ fromString m]@@ -337,19 +330,19 @@ contentsInspection _ _ = return InspectionNone -- crc or smth -- | Inspect file-inspectFile :: [String] -> FilePath -> ExceptT String IO InspectedModule-inspectFile opts file = do+inspectFile :: [String] -> FilePath -> Maybe String -> ExceptT String IO InspectedModule+inspectFile 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"- inspect (FileModule absFilename proj) (fileInspection absFilename opts) $ do+ 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 analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $- readFileUtf8 absFilename+ maybe (readFileUtf8 absFilename) return mcts force analyzed `deepseq` return analyzed -- return $ setLoc absFilename proj . maybe id addDocs docsMap $ forced return $ set moduleLocation (FileModule absFilename proj) forced@@ -365,6 +358,12 @@ tm <- liftE $ Dir.getModificationTime f return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ sort $ ordNub opts +-- | File contents inspection data+fileContentsInspection :: FilePath -> [String] -> ExceptT String IO Inspection+fileContentsInspection _ opts = do+ tm <- liftE getPOSIXTime+ return $ InspectionAt tm $ sort $ ordNub opts+ -- | Enumerate project dirs projectDirs :: Project -> ExceptT String IO [Extensions FilePath] projectDirs p = do@@ -393,4 +392,4 @@ modules <- mapM inspectFile' srcs return (p', catMaybes modules) where- inspectFile' exts = liftM return (inspectFile (opts ++ extensionsOpts exts) (view entity exts)) <|> return Nothing+ inspectFile' exts = liftM return (inspectFile (opts ++ extensionsOpts exts) (view entity exts) Nothing) <|> return Nothing
src/HsDev/Scan.hs view
@@ -14,10 +14,10 @@ ) where import Control.Applicative ((<|>)) -import Control.Lens (view, preview, set, _Right) +import Control.Lens (view, preview, set, _Right, _1, _2, _3, (^.)) import Control.Monad.Except import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust) import System.Directory import HsDev.Scan.Browse (browsePackages) @@ -35,7 +35,7 @@ -- | Compile flags type CompileFlag = String -- | Module with flags ready to scan -type ModuleToScan = (ModuleLocation, [CompileFlag]) +type ModuleToScan = (ModuleLocation, [CompileFlag], Maybe String) -- | Project ready to scan type ProjectToScan = (Project, [ModuleToScan]) -- | Cabal sandbox to scan @@ -62,7 +62,7 @@ ["-package " ++ view projectName p'], ["-package " ++ dep | dep <- view infoDepends i, dep `elem` pkgs]] srcs <- projectSources p' - return (p', [(FileModule (view entity src) (Just p'), extensionsOpts src ++ projOpts (view entity src)) | src <- srcs]) + return (p', [(FileModule (view entity src) (Just p'), extensionsOpts src ++ projOpts (view entity src), Nothing) | src <- srcs]) -- | Enum directory modules enumDirectory :: FilePath -> ExceptT String IO ScanContents @@ -77,8 +77,8 @@ let projPaths = map (view projectPath . fst) projs standalone = map ((`FileModule` Nothing)) $ filter (\s -> not (any (`isParent` s) projPaths)) sources - return $ ScanContents { - modulesToScan = [(s, []) | s <- standalone], + return ScanContents { + modulesToScan = [(s, [], Nothing) | s <- standalone], projectsToScan = projs, sandboxesToScan = map Sandbox sboxes } @@ -89,8 +89,8 @@ loadProject proj -- | Scan module -scanModule :: [String] -> ModuleLocation -> ExceptT String IO InspectedModule -scanModule opts (FileModule f p) = liftM setProj $ inspectFile opts f where +scanModule :: [String] -> ModuleLocation -> Maybe String -> ExceptT String IO InspectedModule +scanModule opts (FileModule f p) mcts = liftM setProj $ inspectFile opts f mcts where setProj = set (inspectedId . moduleProject) p . set (inspectionResult . _Right . moduleLocation . moduleProject) p @@ -98,8 +98,8 @@ -- infer' m = tryInfer <|> return m where -- tryInfer = mapExceptT (withCurrentDirectory (sourceModuleRoot (moduleName m) f)) $ -- runGhcMod defaultOptions $ inferTypes opts Cabal m -scanModule opts (CabalModule c p n) = browse opts c n p -scanModule _ (ModuleSource _) = throwError "Can inspect only modules in file or cabal" +scanModule opts (CabalModule c p n) _ = browse opts c n p +scanModule _ (ModuleSource _) _ = throwError "Can inspect only modules in file or cabal" -- | Scan additional info and modify scanned module. Dones't fail on error, just left module unchanged scanModify :: ([String] -> Cabal -> Module -> ExceptT String IO Module) -> InspectedModule -> ExceptT String IO InspectedModule @@ -120,7 +120,7 @@ up <- upToDate opts im if up then return Nothing - else fmap Just $ scanModule opts (view inspectedId im) + else fmap Just $ scanModule opts (view inspectedId im) Nothing -- | Is module new or recently changed changedModule :: Database -> [String] -> ModuleLocation -> ExceptT String IO Bool @@ -129,4 +129,6 @@ -- | Returns new (to scan) and changed (to rescan) modules changedModules :: Database -> [String] -> [ModuleToScan] -> ExceptT String IO [ModuleToScan] -changedModules db opts = filterM (\ (m, opts') -> changedModule db (opts ++ opts') m) +changedModules db opts = filterM $ \m -> if isJust (m ^. _3) + then return True + else changedModule db (opts ++ (m ^. _2)) (m ^. _1)
tools/hsinspect.hs view
@@ -28,7 +28,7 @@ inspect' (Args [] opts) = liftIO getContents >>= liftM toJSON . inspectContents "stdin" (ghcs opts) inspect' (Args [fname@(takeExtension -> ".hs")] opts) = do fname' <- liftIO $ canonicalizePath fname - im <- scanModule (ghcs opts) (FileModule fname' Nothing) + im <- scanModule (ghcs opts) (FileModule fname' Nothing) Nothing let scanAdditional = scanModify (\opts' _ -> inspectDocs opts') >=> @@ -37,5 +37,5 @@ inspect' (Args [fcabal@(takeExtension -> ".cabal")] _) = do fcabal' <- liftIO $ canonicalizePath fcabal toJSON <$> readProject fcabal' - inspect' (Args [mname] opts) = toJSON <$> scanModule (ghcs opts) (CabalModule Cabal Nothing mname) + inspect' (Args [mname] opts) = toJSON <$> scanModule (ghcs opts) (CabalModule Cabal Nothing mname) Nothing inspect' _ = toolError "Specify module name or file name (.hs or .cabal)"