module FrontEnd.Exports(determineExports,ModInfo(..)) where
import Control.Monad.Identity
import Data.List
import Data.Maybe
import Data.Monoid(Monoid(..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Doc.DocLike
import FindFixpoint
import FlagDump as FD
import FlagOpts as FO
import FrontEnd.HsSyn
import FrontEnd.SrcLoc
import FrontEnd.Warning
import Name.Name as Name
import Options
import Util.Relation as R
import Util.SetLike as SL
data ModInfo = ModInfo {
modInfoName :: Module,
modInfoDefs :: [(Name,SrcLoc,[Name])],
modInfoConsArity :: [(Name,Int)],
modInfoExport :: [Name],
modInfoImport :: [(Name,[Name])],
modInfoHsModule :: HsModule,
modInfoReverseMap :: Map.Map Name Name,
modInfoOptions :: Opt
}
instance Eq ModInfo where
a == b = modInfoName a == modInfoName b
instance Ord ModInfo where
compare a b = compare (modInfoName a) (modInfoName b)
modInfoModImports m = mp [ i | i <- hsModuleImports (modInfoHsModule m)] where
mp xs
| any ((== toModule "Prelude") . hsImportDeclModule) xs = xs
| FO.Prelude `Set.member` (optFOptsSet $ modInfoOptions m) = (prelude:xs)
| otherwise = xs
prelude = HsImportDecl {
hsImportDeclSrcLoc = bogusASrcLoc,
hsImportDeclModule = toModule "Prelude",
hsImportDeclSpec = Nothing,
hsImportDeclAs = Nothing,
hsImportDeclQualified = False }
determineExports :: [(Name,SrcLoc,[Name])] -> [(Module,[Name])] -> [ModInfo] -> IO [ModInfo]
determineExports defs ae ms = do
let ds = [ (n,cs) | (n,_,cs) <- defs ++ concatMap modInfoDefs ms]
ms <- determineExports' ds ae ms
let g m = do
when (dump FD.Imports) $ do
putStrLn $ " -- Imports: " ++ show (modInfoName m)
putStr $ unlines (sort $ map show (modInfoImport m))
when (dump FD.Exports) $ do
putStrLn $ " -- Exports: " ++ show (modInfoName m)
mapM_ putStrLn (sort [ show (nameType n) ++ " " ++ show n | n <- modInfoExport m])
mapM_ g ms
processIOErrors
return ms
determineExports' :: [(Name,[Name])] -> [(Module,[Name])] -> [ModInfo] -> IO [ModInfo]
determineExports' owns doneMods todoMods = mdo
rs <- solve Nothing mempty [ x |(_,_,x) <- ms]
let lf m = maybe (fail $ "determineExports'.lf: " ++ show m) return $ Map.lookup m $ dmodMap `mappend` Map.fromList [ (modInfoName x,fromList [(toUnqualified x,x) | x <- modInfoExport x]) | x <- xs]
let g (mi,ne) = do
ne' <- ce mi ne
return mi { modInfoExport = ne', modInfoImport = toRelationList $ runIdentity $ getImports mi lf }
xs <- mapM g $ zip todoMods rs
return xs
where
ms = [ (i,mi, getExports mi le ) | mi <- todoMods | i <- [0..]]
dmodMap = Map.fromList [ ( x,fromList [(toUnqualified n,n) | n <- xs]) | (x,xs) <- doneMods ]
modMap = fmap return dmodMap `mappend` (Map.fromList [ (modInfoName n,getVal i) | (i,n,_) <- ms])
ownsMap = Map.fromList owns
le m = runIdentity $ maybe (fail $ "determineExports'.le: " ++ show m) return $ Map.lookup m modMap
ce m x = mapM f (toRelationList x) where
f (x,[y]) = return y
f (_,[]) = error "can't happen"
f (x,ys) = warn bogusASrcLoc (AmbiguousExport (modInfoName m) ys) ("module " <> fromModule (modInfoName m) <> " has ambiguous exports: " ++ show ys) >> return (head ys)
getExports :: Monad m => ModInfo -> (Module -> m (Rel Name Name)) -> m (Rel Name Name)
getExports mi@ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing } } _ = return $ defsToRel (modInfoDefs mi)
getExports mi le | HsModule { hsModuleExports = Just es } <- modInfoHsModule mi = do
is <- getImports mi le
let f (HsEModuleContents m) = mapDomain g unqs `intersection` qs where
(qs,unqs) = partitionDomain (isJust . getModule ) is
g x = Name.qualifyName m x
f z = entSpec False is z
return $ mapDomain toUnqualified (unions $ map f es)
getExports _ _ = error "Exports.getExports: bad."
getImports :: Monad m => ModInfo -> (Module -> m (Rel Name Name)) -> m (Rel Name Name)
getImports mi le = mapM f is >>= \xs -> return (mconcat (ls:xs)) where
f x = do
es <- le (hsImportDeclModule x)
Just as <- return $ hsImportDeclAs x `mplus` Just (hsImportDeclModule x)
es' <- case hsImportDeclSpec x of
Nothing -> return es
Just (isHiding,xs) -> do
let listed = mconcat $ map (entSpec isHiding es) xs
return $ if isHiding then es SL.\\ listed else listed
return $ (mapDomain ((Name.qualifyName as)) es' `mappend` if hsImportDeclQualified x then mempty else es')
is = modInfoModImports mi
ls = fromList $ concat [ [(toUnqualified z,z),(z,z)]| (z, _, _) <- modInfoDefs mi]
entSpec ::
Bool
-> Rel Name Name
-> HsExportSpec
-> Rel Name Name
entSpec isHiding rel e = f Nothing e where
f _ (HsEVar n) = restrictDomainS (toName Val n) rel
f Nothing (HsEAbs n) = restrictDomainSet (Set.fromList [ toName x n | x <- ts]) rel where
ts = TypeConstructor:ClassName:if isHiding then [DataConstructor] else []
f (Just nt) (HsEAbs n) = restrictDomainSet (Set.singleton (toName nt n)) rel where
f mnt (HsEThingWith n xs) = restrictDomainSet (fromList (concat (map (`toName` n) ct:(map cd xs)))) rel where
ct = case mnt of
Nothing -> [TypeConstructor,ClassName]
Just nt -> [nt]
cd n = [toName DataConstructor n, toName Val n, toName FieldLabel n ]
f mnt (HsEThingAll n) = rdl `mappend` restrictRange (`elem` ss) rel where
ct = case mnt of
Nothing -> [TypeConstructor,ClassName]
Just nt -> [nt]
ss = concat $ concat [ maybeToList (Map.lookup x ownsMap) | x <- Set.toList $ range rdl ]
rdl = (restrictDomain (`elem` map (`toName` n) ct) rel)
f _ (HsEQualified t n) = f (Just t) n
f _ _ = error "Export.determineExports': bad."
defsToRel xs = fromList $ map f xs where
f (n,_,_) = (toUnqualified n,n)