{-# LANGUAGE DoRec,NoMonoLocalBinds #-}
-- | determine export\/imports for modules via fixpoint recursion

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 }

--doExports :: [(Module,[Name])] -> [[ModInfo]] -> [[ModInfo]] -> IO [[ModInfo]]

determineExports :: [(Name,SrcLoc,[Name])] -> [(Module,[Name])] -> [ModInfo]  -> IO [ModInfo]
determineExports defs ae ms = do
    --wdump FD.Progress $ do
    --    putErrLn $ "Determining Exports/Imports: " ++ show (sort [ m | m <- map modInfoName ms])
        --mapM_ CharIO.print [ (modInfoName m, map hsImportDeclModule $ modInfoModImports m) | m <- ms]
    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."

    -- | determine what is visible in a module
    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 -- return $ (mapDomain ((Name.qualifyName as)) es `mappend` if hsImportDeclQualified x then mempty else 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              -- ^ is it a hiding import?
        -> Rel Name Name  -- ^ the original relation
        -> HsExportSpec   -- ^ the specification
        -> Rel Name Name  -- ^ the subset satisfying the specification
    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 ]
	    --cd n = [toName DataConstructor n, toName Val n, toName FieldLabel n ]
	    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)