module HsDev.Commands (
findDeclaration, findModule,
fileModule,
lookupSymbol,
whois,
scopeModules, scope,
completions,
moduleCompletions,
checkModule, checkDeclaration, restrictCabal, visibleFrom,
splitIdentifier,
fileCtx, fileCtxMaybe
) where
import Control.Applicative
import Control.Monad.Error
import Data.List
import Data.Maybe
import qualified Data.Map as M (lookup)
import Data.String (fromString)
import qualified Data.Text as T (isPrefixOf, split, unpack)
import Data.Traversable (traverse)
import System.Directory (canonicalizePath)
import HsDev.Database
import HsDev.Project
import HsDev.Symbols
import HsDev.Symbols.Resolve
import HsDev.Symbols.Util
import HsDev.Tools.Base (matchRx, at)
import HsDev.Util (liftE)
findDeclaration :: Database -> String -> ErrorT String IO [ModuleDeclaration]
findDeclaration db ident = return $ selectDeclarations checkName db where
checkName :: ModuleDeclaration -> Bool
checkName m =
(declarationName (moduleDeclaration m) == fromString iname) &&
(maybe True ((moduleIdName (declarationModuleId m) ==) . fromString) qname)
(qname, iname) = splitIdentifier ident
findModule :: Database -> String -> ErrorT String IO [Module]
findModule db mname = return $ selectModules ((== fromString mname) . moduleName) db
fileModule :: Database -> FilePath -> ErrorT String IO Module
fileModule db src = do
src' <- liftE $ canonicalizePath src
maybe (throwError $ "File '" ++ src' ++ "' not found") return $ lookupFile src' db
getProject :: Database -> Project -> ErrorT String IO Project
getProject db p = do
p' <- liftE $ canonicalizePath $ projectCabal p
maybe (throwError $ "Project " ++ p' ++ " not found") return $
M.lookup p' $ databaseProjects db
lookupSymbol :: Database -> Cabal -> FilePath -> String -> ErrorT String IO [ModuleDeclaration]
lookupSymbol db cabal file ident = do
(_, mthis, mproj) <- fileCtx db file
liftM
(filter $ checkModule $ allOf [
restrictCabal cabal,
visibleFrom mproj mthis,
maybe (const True) inModule qname])
(newestPackage <$> findDeclaration db iname)
where
(qname, iname) = splitIdentifier ident
whois :: Database -> Cabal -> FilePath -> String -> ErrorT String IO [ModuleDeclaration]
whois db cabal file ident = do
(_, mthis, mproj) <- fileCtx db file
return $
newestPackage $ filter (checkDecl . moduleDeclaration) $
moduleModuleDeclarations $ scopeModule $
resolveOne (fileDeps file cabal mproj db) $
moduleLocals mthis
where
(qname, iname) = splitIdentifier ident
checkDecl d = fmap fromString qname `elem` scopes d && declarationName d == fromString iname
scopeModules :: Database -> Cabal -> FilePath -> ErrorT String IO [Module]
scopeModules db cabal file = do
(file', mthis, mproj) <- fileCtxMaybe db file
newestPackage <$> case mproj of
Nothing -> return $ maybe id (:) mthis $ selectModules (inCabal cabal . moduleId) db
Just proj -> let deps' = deps file' proj in
return $ concatMap (\p -> selectModules (p . moduleId) db) [
inProject proj,
\m -> any (`inPackage` m) deps']
where
deps f p = maybe [] infoDepends $ fileTarget p f
scope :: Database -> Cabal -> FilePath -> Bool -> ErrorT String IO [ModuleDeclaration]
scope db cabal file False = do
(_, mthis, mproj) <- fileCtx db file
return $ moduleModuleDeclarations $ scopeModule $ resolveOne (fileDeps file cabal mproj db) mthis
scope db cabal file True = concatMap moduleModuleDeclarations <$> scopeModules db cabal file
completions :: Database -> Cabal -> FilePath -> String -> Bool -> ErrorT String IO [ModuleDeclaration]
completions db cabal file prefix wide = do
(_, mthis, mproj) <- fileCtx db file
return $
newestPackage $ filter (checkDecl . moduleDeclaration) $
moduleModuleDeclarations $ scopeModule $
resolveOne (fileDeps file cabal mproj db) $
dropImportLists mthis
where
(qname, iname) = splitIdentifier prefix
checkDecl d = fmap fromString qname `elem` scopes d && fromString iname `T.isPrefixOf` declarationName d
dropImportLists m
| wide = m { moduleImports = map dropList (moduleImports m) }
| otherwise = m
dropList i = i { importList = Nothing }
moduleCompletions :: Database -> [Module] -> String -> ErrorT String IO [String]
moduleCompletions _ ms prefix = return $ map T.unpack $ nub $ completions' $ map moduleName ms where
completions' = mapMaybe getNext where
getNext m
| fromString prefix `T.isPrefixOf` m = listToMaybe $ map snd $ dropWhile (uncurry (==)) $ zip (T.split (== '.') $ fromString prefix) (T.split (== '.') m)
| otherwise = Nothing
checkModule :: (ModuleId -> Bool) -> (ModuleDeclaration -> Bool)
checkModule = (. declarationModuleId)
checkDeclaration :: (Declaration -> Bool) -> (ModuleDeclaration -> Bool)
checkDeclaration = (. moduleDeclaration)
restrictCabal :: Cabal -> ModuleId -> Bool
restrictCabal cabal m = inCabal cabal m || not (byCabal m)
visibleFrom :: Maybe Project -> Module -> ModuleId -> Bool
visibleFrom (Just p) this m = visible p (moduleId this) m
visibleFrom Nothing this m = (moduleId this) == m || byCabal m
splitIdentifier :: String -> (Maybe String, String)
splitIdentifier name = fromMaybe (Nothing, name) $ do
groups <- matchRx "(([A-Z][\\w']*\\.)*)(.*)" name
return (fmap dropDot $ groups 1, groups `at` 3)
where
dropDot :: String -> String
dropDot "" = ""
dropDot s = init s
fileCtx :: Database -> FilePath -> ErrorT String IO (FilePath, Module, Maybe Project)
fileCtx db file = do
file' <- liftE $ canonicalizePath file
mthis <- fileModule db file'
mproj <- traverse (getProject db) $ projectOf $ moduleId mthis
return (file', mthis, mproj)
fileCtxMaybe :: Database -> FilePath -> ErrorT String IO (FilePath, Maybe Module, Maybe Project)
fileCtxMaybe db file = ((\(f, m, p) -> (f, Just m, p)) <$> fileCtx db file) <|> onlyProj where
onlyProj = do
file' <- liftE $ canonicalizePath file
mproj <- liftE $ locateProject file'
mproj' <- traverse (getProject db) mproj
return (file', Nothing, mproj')
fileDeps :: FilePath -> Cabal -> Maybe Project -> Database -> Database
fileDeps file cabal mproj = filterDB fileDeps' (const True) where
fileDeps' = liftM2 (||)
(maybe (const True) inProject mproj)
(liftM2 (&&)
(restrictCabal cabal)
(maybe (const True) inDepsOfTarget (join $ fileTarget <$> mproj <*> pure file)))