module HsDev.Symbols.Resolve (
ResolveM(..), ResolvedTree, ResolvedModule(..), scopeModule, exportsModule, resolvedTopScope,
resolve, resolveOne, resolveModule, exported, resolveImport,
mergeImported
) where
import Control.Applicative
import Control.Arrow
import Control.Monad.Reader
import Control.Monad.State
import Data.Foldable (Foldable)
import Data.Function (on)
import Data.List (sortBy, groupBy, find)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, maybeToList, listToMaybe)
import Data.Monoid (mconcat, mappend)
import Data.Ord (comparing)
import Data.String (fromString)
import Data.Text (Text)
import Data.Traversable (Traversable, traverse)
import HsDev.Database
import HsDev.Project
import HsDev.Symbols
import HsDev.Symbols.Util
newtype ResolveM a = ResolveM { runResolveM :: ReaderT Database (State ResolvedTree) a }
deriving (Functor, Applicative, Monad, MonadState ResolvedTree, MonadReader Database)
type ResolvedTree = Map ModuleId ResolvedModule
data ResolvedModule = ResolvedModule {
resolvedModule :: Module,
resolvedScope :: [Declaration],
resolvedExports :: [Declaration] }
scopeModule :: ResolvedModule -> Module
scopeModule r = (resolvedModule r) { moduleDeclarations = resolvedScope r }
exportsModule :: ResolvedModule -> Module
exportsModule r = (resolvedModule r) { moduleDeclarations = resolvedExports r }
resolvedTopScope :: ResolvedModule -> [Declaration]
resolvedTopScope = filter isTop . resolvedScope where
isTop :: Declaration -> Bool
isTop = any (not . importIsQualified) . fromMaybe [] . declarationImported
resolve :: (Traversable t, Foldable t) => Database -> t Module -> t ResolvedModule
resolve db = flip evalState M.empty . flip runReaderT db . runResolveM . traverse resolveModule
resolveOne :: Database -> Module -> ResolvedModule
resolveOne db = fromMaybe (error "Resolve: impossible happened") . resolve db . Just
resolveModule :: Module -> ResolveM ResolvedModule
resolveModule m = gets (M.lookup $ moduleId m) >>= maybe resolveModule' return where
resolveModule' = save $ case moduleLocation m of
CabalModule {} -> return ResolvedModule {
resolvedModule = m,
resolvedScope = moduleDeclarations m,
resolvedExports = moduleDeclarations m }
_ -> do
scope' <-
liftM ((thisDecls ++) . mergeImported . concat) .
mapM (resolveImport m) .
(import_ (fromString "Prelude") :) .
moduleImports $ m
let
exports' =
concatMap (exported scope') .
fromMaybe [] .
moduleExports $ m
return $ ResolvedModule m (sortDeclarations scope') (sortDeclarations exports')
thisDecls :: [Declaration]
thisDecls = map (selfDefined . selfImport) $ moduleDeclarations m
selfDefined :: Declaration -> Declaration
selfDefined d = d { declarationDefined = Just (moduleId m) }
selfImport :: Declaration -> Declaration
selfImport d = d { declarationImported = Just [import_ $ moduleName m] }
save :: ResolveM ResolvedModule -> ResolveM ResolvedModule
save act = do
rm <- act
modify $ M.insert (moduleId (resolvedModule rm)) rm
return rm
exported :: [Declaration] -> Export -> [Declaration]
exported ds (ExportName q n) = maybeToList $ find isExported ds where
isExported :: Declaration -> Bool
isExported decl' = declarationName decl' == n && case q of
Nothing -> any (not . importIsQualified) $ fromMaybe [] $ declarationImported decl'
Just q' -> any ((== q') . importName) $ fromMaybe [] $ declarationImported decl'
exported ds (ExportModule m) =
filter (any (unqualBy m) . fromMaybe [] . declarationImported) ds
where
unqualBy :: Text -> Import -> Bool
unqualBy m' i = importName i == m' && not (importIsQualified i)
resolveImport :: Module -> Import -> ResolveM [Declaration]
resolveImport m i = liftM (map $ setImport i) resolveImport' where
resolveImport' :: ResolveM [Declaration]
resolveImport' = do
ms <- case moduleLocation m of
FileModule file proj -> do
db <- ask
let
proj' = proj >>= refineProject db
case proj' of
Nothing -> selectImport i [
inFile $ importedModulePath (moduleName m) file (importModuleName i),
byCabal]
Just p -> selectImport i [
inProject p,
inDepsOf' file p]
CabalModule cabal _ _ -> selectImport i [inCabal cabal]
ModuleSource _ -> selectImport i [byCabal]
liftM (filterImportList . concatMap resolvedExports) $ mapM resolveModule ms
setImport :: Import -> Declaration -> Declaration
setImport i' d' = d' { declarationImported = Just [i'] `mappend` declarationImported d' }
selectImport :: Import -> [ModuleId -> Bool] -> ResolveM [Module]
selectImport i' fs = do
db <- ask
return $
fromMaybe [] $
listToMaybe $ dropWhile null $
[selectModules (select' f) db | f <- byImport i' : fs]
where
select' f md = moduleName md == importModuleName i' && f (moduleId md)
filterImportList :: [Declaration] -> [Declaration]
filterImportList = case importList i of
Nothing -> id
Just il -> filter (passImportList il . declarationName)
byImport :: Import -> ModuleId -> Bool
byImport i' m' = importModuleName i' == moduleIdName m'
deps f p = maybe [] infoDepends $ fileTarget p f
inDepsOf' f p m' = any (`inPackage` m') (deps f p)
mergeImported :: [Declaration] -> [Declaration]
mergeImported =
map merge' .
groupBy ((==) `on` declId) .
sortBy (comparing declId)
where
declId :: Declaration -> (Text, Maybe ModuleId)
declId = declarationName &&& declarationDefined
merge' :: [Declaration] -> Declaration
merge' [] = error "mergeImported: impossible"
merge' ds@(d:_) = d { declarationImported = mconcat $ map declarationImported ds }