{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Metainfo.Provider
-- Copyright   :  (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GNU-GPL
--
-- Maintainer  :  <maintainer at leksah.org>
-- Stability   :  provisional
-- Portability :  portable
--
-- | This module provides the infos collected by the extractor before
--   and an info pane to present some of them to the user
--
---------------------------------------------------------------------------------

module IDE.Metainfo.Provider (
    getIdentifierDescr
,   getIdentifiersStartingWith
,   getCompletionOptions
,   getDescription
,   getActivePackageDescr

,   initInfo
,   updateAccessibleInfo
,   infoForActivePackage
,   rebuildActiveInfo
,   searchMeta
,   rebuildLibInfo
) where

import System.IO
import qualified Data.Map as Map
import Config
import Control.Monad
import Control.Monad.Trans
import System.FilePath
import System.Directory
import qualified Data.Map as Map
import System.IO
import Data.List
import qualified PackageConfig as DP
import Data.Maybe
import Distribution.Package hiding (depends,packageId)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BSL
import Distribution.Version
import Distribution.ModuleName
import GHC (runGhc)

import DeepSeq
import IDE.FileUtils
import IDE.Core.State
import IDE.Metainfo.InterfaceCollector
import Data.Char (toLower,isUpper,toUpper,isLower)
import Text.Regex.Posix
import System.IO.Unsafe (unsafePerformIO)
import Text.Regex.Posix.String (execute,compile)
import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos,inGhc)
import Data.Binary.Shared (decodeSer)
import System.Mem (performGC)

getActivePackageDescr :: IDEM (Maybe PackageDescr)
getActivePackageDescr = do
    mbActive <- readIDE activePack
    case mbActive of
        Nothing -> return Nothing
        Just pack -> do
            currentInfo' <- readIDE currentInfo
            case currentInfo' of
                Nothing -> return Nothing
                Just ((map,_),(_,_)) -> return (packageId pack `Map.lookup` map)

--
-- | Lookup of an identifier description
--
getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [Descr]
getIdentifierDescr str st1 st2 =
    let r1 = case str `Map.lookup` st1 of
                Nothing -> []
                Just r -> r
        r2 = case str `Map.lookup` st2 of
                Nothing -> []
                Just r -> r
    in r1 ++ r2

--
-- | Lookup of an identifiers starting with the specified prefix and return a list.
--
getIdentifiersStartingWith :: String -> SymbolTable -> SymbolTable -> [String]
getIdentifiersStartingWith prefix st1 st2 =
    takeWhile (isPrefixOf prefix) $
        if memberLocal || memberGlobal then
            prefix : Set.toAscList names
            else
            Set.toAscList names
    where
        (_, memberLocal, localNames) = Set.splitMember prefix (Map.keysSet st1)
        (_, memberGlobal, globalNames) = Set.splitMember prefix (Map.keysSet st2)
        names = Set.union globalNames localNames

getCompletionOptions :: String -> IDEM [String]
getCompletionOptions prefix = do
    currentInfo' <- readIDE currentInfo
    case currentInfo' of
        Nothing -> return []
        Just ((_,symbolTable1),(_,symbolTable2)) ->
            return $ getIdentifiersStartingWith prefix symbolTable1 symbolTable2

getDescription :: String -> IDEM String
getDescription name = do
    currentInfo' <- readIDE currentInfo
    case currentInfo' of
        Nothing -> return ""
        Just ((_,symbolTable1),(_,symbolTable2)) ->
            return ((foldr (\d f -> shows (Present d) . showChar '\n' . f) id
                (getIdentifierDescr name symbolTable1 symbolTable2)) "")

--
-- | Searching of metadata
--

searchMeta :: Scope -> String -> SearchMode -> IDEM [Descr]
searchMeta _ "" _ = return []
searchMeta Local searchString searchType = do
    currentInfo'    <- readIDE currentInfo
    case currentInfo' of
        Nothing    -> return []
        Just (l,_) -> return (searchInScope searchType searchString (snd l))
searchMeta Package searchString searchType = do
    currentInfo'    <- readIDE currentInfo
    case currentInfo' of
        Nothing    -> return []
        Just (l,p) -> return (searchInScope searchType searchString (snd l)
                                ++  searchInScope searchType searchString (snd p))
searchMeta System searchString searchType = do
    accessibleInfo' <- readIDE accessibleInfo
    let s = case accessibleInfo' of
                Nothing        -> Map.empty
                Just (_,scope) -> scope
    currentInfo'    <- readIDE currentInfo
    case currentInfo' of
        Nothing    -> return (searchInScope searchType searchString s)
        Just (l,_) -> return (searchInScope searchType searchString (snd l)
                                ++  searchInScope searchType searchString s)


searchInScope :: SearchMode -> String -> SymbolTable -> [Descr]
searchInScope (Exact _)  l st      = searchInScopeExact l st
searchInScope (Prefix True) l st   = (concat . Map.elems) (searchInScopePrefix l st)
searchInScope (Prefix False) [] _  = []
searchInScope (Prefix False) l st  = (concat . Map.elems) (searchInScopeCaseIns l st "")
searchInScope (Regex b) l st       = searchRegex l st b


searchInScopeExact :: String -> SymbolTable -> [Descr]
searchInScopeExact searchString symbolTable =
    case Map.lookup searchString symbolTable of
        Nothing -> []
        Just l  -> l

searchInScopePrefix :: String -> SymbolTable -> SymbolTable
searchInScopePrefix searchString symbolTable =
    let (_, exact, mapR)   = Map.splitLookup searchString symbolTable
        (mbL, _, _)        = Map.splitLookup (searchString ++ "{") mapR
    in case exact of
            Nothing -> mbL
            Just e  -> Map.insert searchString e mbL

searchInScopeCaseIns :: String -> SymbolTable -> String -> SymbolTable
searchInScopeCaseIns [] st _                    =  st
searchInScopeCaseIns (a:l)  st pre | isLower a  =
    let s1 = pre ++ [a]
        s2 = pre ++ [toUpper a]
    in  (Map.union (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1)
                   (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2))
                                   | isUpper a  =
    let s1 = pre ++ [a]
        s2 = pre ++ [toLower a]
    in  (Map.union (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1)
                   (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2))
                                    | otherwise =
    let s =  pre ++ [a]
    in searchInScopeCaseIns l (searchInScopePrefix s st) s

searchRegex :: String -> SymbolTable -> Bool -> [Descr]
searchRegex searchString st caseSense =
    unsafePerformIO $ do
        res <- compile (if caseSense then compBlank else compIgnoreCase)
                    execBlank searchString
        case res of
            Left err -> do
                sysMessage Normal (show err)
                return []
            Right regex ->
                filterM (\e -> do
                    res <- execute regex (descrName e)
                    case res of
                        Left e        -> return False
                        Right Nothing -> return False
                        _             -> return True)
                            (concat (Map.elems st))

--
-- | Update and initialize metadata for the world
--
initInfo :: IDEAction
initInfo = do
    prefs           <- readIDE prefs
    when (collectAtStart prefs) $ do
        ideMessage Normal "Now updating metadata ..."
        collectInstalled prefs False
    ideMessage Normal "Now loading metadata ..."
    loadAccessibleInfo
    ideMessage Normal "Finished loading ..."

--
-- | Load all infos for all installed and exposed packages
--   (see shell command: ghc-pkg list)
--
loadAccessibleInfo :: IDEAction
loadAccessibleInfo =
    let version     =   cProjectVersion in do
        collectorPath   <-  lift $ getCollectorPath version
        packageInfos    <-  inGhc $ getInstalledPackageInfos
 --       trace ("allInfos " ++ show (map (DP.unpackPackageId . DP.packageConfigId) packageInfos)) $ return ()
        packageList     <-  liftIO $ mapM (loadInfosForPackage collectorPath False)
                                                    (map DP.package packageInfos)
        let scope       =   foldr buildScope (Map.empty,Map.empty)
                                $ map fromJust
                                    $ filter isJust packageList
        liftIO performGC
        modifyIDE_ (\ide -> ide{accessibleInfo = (Just scope)})

--
-- | Clears the current info, not the world infos
--
clearCurrentInfo :: IDEAction
clearCurrentInfo = do
    modifyIDE_ (\ide    ->  ide{currentInfo = Nothing})
    triggerEventIDE CurrentInfo
    return ()

--
-- | Set info for package
--
infoForActivePackage :: IDEAction
infoForActivePackage  = do
    activePack          <-  readIDE activePack
    case activePack of
        Nothing         ->  do
            modifyIDE_ (\ide -> ide{currentInfo = Nothing})
        Just pack       ->  do
            let depends'         =  depends pack
            fp                  <-  inGhc $ findFittingPackages depends'
            mbActive            <-  loadOrBuildActiveInfo
            case mbActive of
                Nothing         ->  do
                    -- no meta info available
                    modifyIDE_ (\ide -> ide{currentInfo = Nothing})
                Just active     ->  do

                    accessibleInfo'     <-  readIDE accessibleInfo
                    case accessibleInfo' of
                        Nothing         ->  modifyIDE_ (\ide -> ide{currentInfo = Nothing})
                        Just (pdmap,_)  ->  do
                            let packageList =   map (\ pin -> pin `Map.lookup` pdmap) fp
                            let scope       =   foldr buildScope (Map.empty,Map.empty)
                                                    $ map fromJust
                                                        $ filter isJust packageList
                            modifyIDE_ (\ide -> ide{currentInfo = Just (active, scope)})
    triggerEventIDE CurrentInfo
    return ()


--
-- | Builds the current info for the activePackage
--
rebuildActiveInfo :: IDEAction
rebuildActiveInfo       =   setInfo buildActiveInfo

--
-- | Builds the current info for the activePackage
--
setInfo :: IDEM (Maybe PackageScope) -> IDEAction
setInfo f = do
    currentInfo         <-  readIDE currentInfo
    case currentInfo of
        Nothing                 -> return ()
        Just (active, scope)    -> do
            newActive   <-  f
            case newActive of
                Nothing         -> return ()
                Just newActive  -> do
                    modifyIDE_ (\ide -> ide{currentInfo = Just (newActive, scope)})
                    triggerEventIDE CurrentInfo
                    return ()

--
-- | Loads the current info for the activePackage, or builds it if not available
--
loadOrBuildActiveInfo :: IDEM (Maybe PackageScope)
loadOrBuildActiveInfo = do
    mbActiveInfo        <-  loadActiveInfo
    case mbActiveInfo of
        Just ai         ->  return (Just ai)
        Nothing         ->  buildActiveInfo

--
-- | Loads the current info for the activePackage
--
loadActiveInfo :: IDEM (Maybe PackageScope)
loadActiveInfo =
    let version         =   cProjectVersion in do
    activePack          <-  readIDE activePack
    case activePack of
        Nothing         ->  return Nothing
        Just idePackage ->  do
            collectorPath   <-  lift $ getCollectorPath cProjectVersion
            packageDescr    <-  liftIO $ loadInfosForPackage collectorPath True
                                            (packageId idePackage)
            case packageDescr of
                Nothing     -> return Nothing
                Just pd     -> do
                    let scope       =   buildScope pd (Map.empty,Map.empty)
                    return (Just scope)

--
-- | Builds the current info for the activePackage
--
buildActiveInfo :: IDEM (Maybe PackageScope)
buildActiveInfo =
    let version         =   cProjectVersion in do
    activePack          <-  readIDE activePack
    case activePack of
        Nothing         ->  return Nothing
        Just idePackage ->  do
            libDir          <-   liftIO $ getSysLibDir
            liftIO $ runGhc (Just libDir)
                        $ collectUninstalled False cProjectVersion (takeFileName $ cabalFile idePackage)
            -- ideMessage Normal "uninstalled collected"
            collectorPath   <-  lift $ getCollectorPath cProjectVersion
            packageDescr    <-  liftIO $ loadInfosForPackage collectorPath True
                                            (packageId idePackage)
            case packageDescr of
                Nothing     -> return Nothing
                Just pd     -> do
                    let scope       =   buildScope pd (Map.empty,Map.empty)
                    return (Just scope)

rebuildLibInfo :: IDEAction
rebuildLibInfo = do
    updateAccessibleInfo
    rebuildActiveInfo

--
-- | Updates the world info (it is the responsibility of the caller to rebuild
--   the current info)
--
updateAccessibleInfo :: IDEAction
updateAccessibleInfo = do
    wi              <-  readIDE accessibleInfo
    let version     =   cProjectVersion
    case wi of
        Nothing -> loadAccessibleInfo
        Just (psmap,psst) -> do
            packageInfos        <-  inGhc getInstalledPackageInfos
            let packageIds      =   map DP.package packageInfos
            let newPackages     =   filter (\ pi -> Map.member pi psmap) packageIds
            let trashPackages   =   filter (\ e  -> not (elem e packageIds))(Map.keys psmap)
            if null newPackages && null trashPackages
                then return ()
                else do
                    collectorPath   <-  lift $ getCollectorPath version
                    newPackageInfos <-  liftIO $ mapM (\pid -> loadInfosForPackage collectorPath False pid)
                                                        newPackages
                    let psamp2      =   foldr (\e m -> Map.insert (packagePD e) e m)
                                                psmap
                                                (map fromJust
                                                    $ filter isJust newPackageInfos)
                    let psamp3      =   foldr (\e m -> Map.delete e m) psmap trashPackages
                    let scope       =   foldr buildScope (Map.empty,Map.empty)
                                            (Map.elems psamp3)
                    modifyIDE_ (\ide -> ide{accessibleInfo = Just scope})

--
-- | Loads the infos for the given packages
--
loadInfosForPackage :: FilePath -> Bool -> PackageIdentifier -> IO (Maybe PackageDescr)
loadInfosForPackage dirPath isWorkingPackage pid = do
    let filePath = dirPath </> fromPackageIdentifier pid ++ (if isWorkingPackage then ".packw" else ".pack")
    exists <- doesFileExist filePath
    if exists
        then catch (do
            file            <-  openBinaryFile filePath ReadMode
            -- trace ("now loading metadata for package" ++ filePath) return ()
            bs              <-  BSL.hGetContents file
            let (metadataVersion', packageInfo) =   decodeSer bs
            if metadataVersion /= metadataVersion'
                then do
                    hClose file
                    throwIDE ("Metadata has a wrong version."
                            ++  " Consider rebuilding metadata with -r option")
                else do
                    packageInfo `deepSeq` (hClose file)
                    return (Just packageInfo))
            (\e -> do sysMessage Normal (show e); return Nothing)
        else do
            sysMessage Normal $"packageInfo not found for " ++ fromPackageIdentifier pid
            return Nothing

--
-- | Loads the infos for the given packages (has an collecting argument)
--
buildScope :: PackageDescr -> PackageScope -> PackageScope
buildScope packageD (packageMap, symbolTable) =
    let pid = packagePD packageD
    in if pid `Map.member` packageMap
        then (packageMap, symbolTable)
        else (Map.insert pid packageD packageMap,
              buildSymbolTable packageD symbolTable)

buildSymbolTable :: PackageDescr -> SymbolTable -> SymbolTable
buildSymbolTable pDescr symbolTable =
     foldl' buildScope symbolTable allDescriptions
    where
        allDescriptions =  concatMap idDescriptionsMD (exposedModulesPD pDescr)
        buildScope st idDescr =
            let allDescrs = allDescrsFrom idDescr
            in  foldl' (\ map descr -> Map.insertWith (++) (descrName descr) [descr] map)
                        st allDescrs
        allDescrsFrom descr | isReexported descr = [descr]
                            | otherwise =
            case details descr of
                DataDescr constructors fields ->
                    descr : (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty,
                        descrModu' = descrModu descr, mbLocation' = mbLocation descr,
                        mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})
                            fields
                            ++  (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty,
                            descrModu' = descrModu descr, mbLocation' = mbLocation descr,
                            mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})
                                constructors))
                ClassDescr _ methods ->
                    descr : (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty,
                        descrModu' = descrModu descr, mbLocation' = mbLocation descr,
                        mbComment' = mbComment descr, details' = MethodDescr {classDescrM = descr}})
                            methods)
                NewtypeDescr constr mbField ->
                    descr : Descr{descrName' = fst constr, typeInfo' = snd constr,
                            descrModu' = descrModu descr, mbLocation' = mbLocation descr,
                            mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}}
                             : case mbField of
                                    Just fld ->
                                        [Descr{descrName' = fst fld, typeInfo' = snd fld,
                                        descrModu' = descrModu descr, mbLocation' = mbLocation descr,
                                        mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}}]
                                    Nothing -> []
                InstanceDescr _ -> []
                _ -> [descr]



-- ---------------------------------------------------------------------
-- DeepSeq instances for forcing evaluation
--

instance DeepSeq Location where
    deepSeq pd =  deepSeq (locationSLine pd)
                    $   deepSeq (locationSCol pd)
                    $   deepSeq (locationELine pd)
                    $   deepSeq (locationECol pd)

instance DeepSeq PackageDescr where
    deepSeq pd =  deepSeq (packagePD pd)
                    $   deepSeq (mbSourcePathPD pd)
                    $   deepSeq (exposedModulesPD pd)
                    $   deepSeq (buildDependsPD pd)

instance DeepSeq ModuleDescr where
    deepSeq pd =  deepSeq (moduleIdMD pd)
                    $   deepSeq (mbSourcePathMD pd)
                    $   deepSeq (exportedNamesMD pd)
                    $   deepSeq (referencesMD pd)

instance DeepSeq Descr where
    deepSeq (Descr descrName' typeInfo' descrModu'
        mbLocation' mbComment' details')  =  deepSeq descrName'
                    $   deepSeq typeInfo'
                    $   deepSeq descrModu'
                    $   deepSeq mbLocation'
                    $   deepSeq mbComment'
                    $   deepSeq details'
    deepSeq (Reexported reexpModu' impDescr') = deepSeq reexpModu'
                    $   deepSeq impDescr'

instance DeepSeq SpDescr where
    deepSeq (FieldDescr typeDescrF')              =   deepSeq typeDescrF'
    deepSeq (ConstructorDescr typeDescrC')        =  deepSeq typeDescrC'
    deepSeq (DataDescr constructors' fields')     =   deepSeq constructors'
                    $   deepSeq fields'
    deepSeq (NewtypeDescr constructor' mbField')  =   deepSeq constructor'
                    $   deepSeq mbField'
    deepSeq (ClassDescr super' methods')          =   deepSeq super'
                    $   deepSeq methods'
    deepSeq (MethodDescr classDescrM')            =   deepSeq classDescrM'
    deepSeq (InstanceDescr binds')                =   deepSeq binds'
    deepSeq a                                     =   seq a


instance DeepSeq PackageIdentifier where
    deepSeq pd =  deepSeq (pkgName pd)
                    $   deepSeq (pkgVersion pd)

instance DeepSeq alpha  => DeepSeq (Set alpha) where
    deepSeq s =  deepSeq (Set.elems s)

instance (DeepSeq alpha, DeepSeq beta) => DeepSeq (Map alpha beta) where
    deepSeq s =  deepSeq (Map.toList s)

instance DeepSeq DescrType where  deepSeq = seq

instance DeepSeq BS.ByteString where  deepSeq = seq

instance DeepSeq Version where  deepSeq = seq

instance DeepSeq PackModule where
    deepSeq pd =  deepSeq (pack pd)
                    $   deepSeq (modu pd)

instance DeepSeq ModuleName where
    deepSeq =  deepSeq . components

instance DeepSeq PackageName where
    deepSeq (PackageName s) =  deepSeq s