module HsDev.Symbols (
export,
passThingSpec, passImportSpec, imported, exported,
importNames, import_,
Symbol(..),
unnamedModuleId,
sortDeclarations, moduleLocals,
setDefinedIn, dropExternals, clearDefinedIn,
moduleLocalDeclarations, moduleModuleDeclarations,
Locals(..),
decl, definedIn, declarationLocals, scopes,
mergeExported,
importQualifier,
locateProject, searchProject,
locateSourceDir,
moduleOpts,
addDeclaration,
unalias,
module HsDev.Symbols.Types,
module HsDev.Symbols.Class,
module HsDev.Symbols.Documented
) where
import Control.Applicative
import Control.Arrow
import Control.Lens
import Control.Monad.Trans.Maybe
import Control.Monad.Except
import Data.Function (on)
import Data.List
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Text (Text)
import qualified Data.Text as T (concat)
import System.Directory
import System.FilePath
import System.Directory.Paths
import HsDev.Symbols.Types
import HsDev.Symbols.Class
import HsDev.Symbols.Documented (Documented(..))
import HsDev.Util (searchPath)
export :: Export -> Text
export (ExportName Nothing n _) = n
export (ExportName (Just q) n _) = T.concat [q, ".", n]
export (ExportModule m) = m
passThingSpec :: Text -> ThingPart -> Bool
passThingSpec _ ThingNothing = False
passThingSpec _ ThingAll = True
passThingSpec n (ThingWith ns) = n `elem` ns
passImportSpec :: Declaration -> ImportSpec -> Bool
passImportSpec decl' (ImportSpec n p)
| view declarationName decl' == n = True
| preview (declaration . related . _Just) decl' == Just n = view declarationName decl' `passThingSpec` p
| otherwise = False
imported :: Declaration -> ImportList -> Bool
imported decl' (ImportList hiding specs) = invert $ any (decl' `passImportSpec`) specs where
invert = if hiding then not else id
exported :: Declaration -> Export -> Bool
exported decl' (ExportName q n p)
| view declarationName decl' == n = checkImport
| preview (declaration . related . _Just) decl' == Just n = view declarationName decl' `passThingSpec` p
| otherwise = False
where
checkImport = case q of
Nothing -> any (not . view importIsQualified) $ fromMaybe [] $ view declarationImported decl'
Just q' -> any ((q' `elem`) . importNames) $ fromMaybe [] $ view declarationImported decl'
exported decl' (ExportModule m) = any (unqualBy m) . fromMaybe [] . view declarationImported $ decl' where
unqualBy :: Text -> Import -> Bool
unqualBy m' i = m' `elem` importNames i && not (view importIsQualified i)
importNames :: Import -> [Text]
importNames i = view importModuleName i : maybe [] return (view importAs i)
import_ :: Text -> Import
import_ n = Import n False Nothing Nothing Nothing
importQualifier :: Maybe Text -> Import -> Bool
importQualifier Nothing i
| not (view importIsQualified i) = True
| otherwise = False
importQualifier (Just q) i
| q == view importModuleName i = True
| Just q == view importAs i = True
| otherwise = False
unnamedModuleId :: ModuleLocation -> ModuleId
unnamedModuleId = ModuleId ""
sortDeclarations :: [Declaration] -> [Declaration]
sortDeclarations = sortBy (comparing (view declarationName))
moduleLocals :: Module -> Module
moduleLocals m = set moduleDeclarations (moduleLocalDeclarations m) m
setDefinedIn :: Module -> Module
setDefinedIn m = over moduleDeclarations (map (`definedIn` view moduleId m)) m
dropExternals :: Module -> Module
dropExternals m = over moduleDeclarations (filter ((/= Just (view moduleId m)) . view declarationDefined)) m
clearDefinedIn :: Module -> Module
clearDefinedIn = over moduleDeclarations (map (set declarationDefined Nothing))
moduleLocalDeclarations :: Module -> [Declaration]
moduleLocalDeclarations =
sortDeclarations .
concatMap declarationLocals' .
view moduleDeclarations
where
declarationLocals' :: Declaration -> [Declaration]
declarationLocals' d = d : declarationLocals d
moduleModuleDeclarations :: Module -> [ModuleDeclaration]
moduleModuleDeclarations m = [ModuleDeclaration (view moduleId m) d | d <- view moduleDeclarations m]
class Locals a where
locals :: a -> [Declaration]
where_ :: a -> [Declaration] -> a
instance Locals Declaration where
locals = locals . view declaration
where_ d ds = over declaration (`where_` ds) d
decl :: Text -> DeclarationInfo -> Declaration
decl n = Declaration n Nothing Nothing Nothing Nothing
definedIn :: Declaration -> ModuleId -> Declaration
definedIn d m = set declarationDefined (Just m) d
declarationLocals :: Declaration -> [Declaration]
declarationLocals d = locals $ view declaration d
scopes :: Declaration -> [Maybe Text]
scopes d = globalScope $ concatMap (map Just . importNames) is where
is = fromMaybe [] $ view declarationImported d
globalScope
| any (not . view importIsQualified) is = (Nothing :)
| otherwise = id
instance Locals DeclarationInfo where
locals (Function _ ds _) = ds
locals _ = []
where_ (Function n s r) ds = Function n (s ++ ds) r
where_ d _ = d
mergeExported :: [ModuleDeclaration] -> [ExportedDeclaration]
mergeExported =
map merge' .
groupBy ((==) `on` declId) .
sortBy (comparing declId)
where
declId :: ModuleDeclaration -> (Text, Maybe ModuleId)
declId = view moduleDeclaration >>> (view declarationName &&& view declarationDefined)
merge' :: [ModuleDeclaration] -> ExportedDeclaration
merge' [] = error "mergeExported: impossible"
merge' ds@(d:_) = ExportedDeclaration (map (view declarationModuleId) ds) (view moduleDeclaration d)
instance Paths Project where
paths f (Project nm p c desc) = Project nm <$> f p <*> f c <*> pure desc
instance Paths ModuleLocation where
paths f (FileModule fpath p) = FileModule <$> f fpath <*> traverse (paths f) p
paths f (InstalledModule c p n) = InstalledModule <$> paths f c <*> pure p <*> pure n
paths _ (ModuleSource m) = pure $ ModuleSource m
locateProject :: FilePath -> IO (Maybe Project)
locateProject file = do
file' <- canonicalizePath file
isDir <- doesDirectoryExist file'
if isDir then locateHere file' else locateParent (takeDirectory file')
where
locateHere path = do
cts <- filter (not . null . takeBaseName) <$> getDirectoryContents path
return $ fmap (project . (path </>)) $ find ((== ".cabal") . takeExtension) cts
locateParent dir = do
cts <- filter (not . null . takeBaseName) <$> getDirectoryContents dir
case find ((== ".cabal") . takeExtension) cts of
Nothing -> if isDrive dir then return Nothing else locateParent (takeDirectory dir)
Just cabalf -> return $ Just $ project (dir </> cabalf)
searchProject :: FilePath -> IO (Maybe Project)
searchProject file = runMaybeT $ searchPath file (MaybeT . locateProject) <|> mzero
locateSourceDir :: FilePath -> IO (Maybe (Extensions FilePath))
locateSourceDir f = runMaybeT $ do
file <- liftIO $ canonicalizePath f
p <- MaybeT $ locateProject file
proj <- MaybeT $ fmap (either (const Nothing) Just) $ runExceptT $ loadProject p
MaybeT $ return $ findSourceDir proj file
moduleOpts :: [ModulePackage] -> Module -> [String]
moduleOpts pkgs m = case view moduleLocation m of
FileModule file proj -> concat [
hidePackages,
targetOpts info']
where
infos' = maybe [] (`fileTargets` file) proj
info' = over infoDepends (filter validDep) (mconcat $ selfInfo : infos')
selfInfo
| proj ^? _Just . projectName `elem` map Just (infos' ^.. each . infoDepends . each) = fromMaybe mempty $
proj ^? _Just . projectDescription . _Just . projectLibrary . _Just . libraryBuildInfo
| otherwise = mempty
validDep d = d `elem` pkgs'
pkgs' = pkgs ^.. each . packageName
hidePackages
| null (info' ^. infoDepends) = []
| otherwise = ["-hide-all-packages"]
_ -> []
addDeclaration :: Declaration -> Module -> Module
addDeclaration decl' = over moduleDeclarations (sortDeclarations . (decl' :))
unalias :: Module -> Text -> [Text]
unalias m alias = [view importModuleName i | i <- view moduleImports m, view importAs i == Just alias]