module Language.Haskell.Names.Recursive
( computeInterfaces
, getInterfaces
, annotateModule
) where
import Data.Graph(stronglyConnComp, flattenSCC)
import Data.Monoid
import Data.Data (Data)
import qualified Data.Set as Set
import Control.Monad hiding (forM_)
import Language.Haskell.Exts.Annotated
import Distribution.HaskellSuite.Modules
import Data.Maybe
import Data.Foldable
import Language.Haskell.Names.Types
import Language.Haskell.Names.SyntaxUtils
import Language.Haskell.Names.ScopeUtils
import Language.Haskell.Names.ModuleSymbols
import Language.Haskell.Names.Exports
import Language.Haskell.Names.Imports
import Language.Haskell.Names.Open.Base
import Language.Haskell.Names.Annotated
groupModules :: forall l . [Module l] -> [[Module l]]
groupModules modules =
map flattenSCC $ stronglyConnComp $ map mkNode modules
where
mkNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])
mkNode m =
( m
, dropAnn $ getModuleName m
, map (dropAnn . importModule) $ getImports m
)
annotateModule
:: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Eq l)
=> Language
-> [Extension]
-> Module l
-> m (Module (Scoped l))
annotateModule lang exts mod@(Module lm mh os is ds) = do
let extSet = moduleExtensions lang exts mod
(imp, impTbl) <- processImports extSet is
let ownTbl = moduleTable mod
tbl = impTbl <> ownTbl
(exp, _syms) <- processExports tbl mod
let
lm' = none lm
os' = fmap noScope os
is' = imp
ds' = annotate (initialScope tbl) `map` ds
mh' = flip fmap mh $ \(ModuleHead lh n mw _me) ->
let
lh' = none lh
n' = noScope n
mw' = fmap noScope mw
me' = exp
in ModuleHead lh' n' mw' me'
return $ Module lm' mh' os' is' ds'
annotateModule _ _ _ = error "annotateModule: non-standard modules are not supported"
findFixPoint
:: (Ord l, Data l, MonadModule m, ModuleInfo m ~ Symbols)
=> [(Module l, ExtensionSet)]
-> m (Set.Set (Error l))
findFixPoint mods = go mods (map (const mempty) mods) where
go mods syms = do
forM_ (zip syms mods) $ \(s,(m, _)) -> insertInCache (getModuleName m) s
(syms', errors) <- liftM unzip $ forM mods $ \(m, extSet) -> do
(imp, impTbl) <- processImports extSet $ getImports m
let ownTbl = moduleTable m
tbl = impTbl <> ownTbl
(exp, syms) <- processExports tbl m
return (syms, foldMap getErrors imp <> foldMap getErrors exp)
if syms' == syms
then return $ mconcat errors
else go mods syms'
computeInterfaces
:: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)
=> Language
-> [Extension]
-> [Module l]
-> m (Set.Set (Error l))
computeInterfaces lang exts =
liftM fold . mapM findFixPoint . map supplyExtensions . groupModules
where
supplyExtensions = map $ \m -> (m, moduleExtensions lang exts m)
getInterfaces
:: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)
=> Language
-> [Extension]
-> [Module l]
-> m ([Symbols], Set.Set (Error l))
getInterfaces lang exts mods = do
errs <- computeInterfaces lang exts mods
ifaces <- forM mods $ \mod ->
let modName = getModuleName mod in
fromMaybe (error $ msg modName) `liftM` lookupInCache modName
return (ifaces, errs)
where
msg modName = "getInterfaces: module " ++ modToString modName ++ " is not in the cache"