{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Metainfo.InterfaceCollector
-- Copyright   :  (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GNU-GPL
--
-- Maintainer  :  <maintainer at leksah.org>
-- Stability   :  provisional
-- Portability :  portable
--
-- | This modulle extracts information from .hi files for installed packages
--
-------------------------------------------------------------------------------

module IDE.Metainfo.InterfaceCollector (
    collectPackageFromHI
,   extractExportedDescrH
,   extractExportedDescrR
) where

import MyMissing (nonEmptyLines)
import Module hiding (PackageId,ModuleName)
import qualified Module as Module (ModuleName)
import qualified Maybes as M
#if MIN_VERSION_ghc(7,2,0)
import HscTypes
import GhcMonad hiding (liftIO)
import qualified GhcMonad as Hs (liftIO)
#else
import HscTypes hiding (liftIO)
import qualified HscTypes as Hs (liftIO)
#endif
#if MIN_VERSION_ghc(7,3,0)
import Avail
import TysWiredIn ( eqTyConName )
#endif
import LoadIface
import Outputable hiding(trace)
import IfaceSyn
import FastString
import Name
import PrelNames
#if MIN_VERSION_ghc(6,12,1)
import PackageConfig (PackageConfig, mkPackageId)
#else
import PackageConfig
       (PackageConfig, mkPackageId)
#endif
import TcRnTypes
import Data.Char (isSpace)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Package hiding (PackageId)
import Distribution.ModuleName
import Distribution.Text (simpleParse)
import qualified Data.ByteString.Char8 as BS
import IDE.Core.Serializable ()
import IDE.Core.CTypes
import Data.ByteString.Char8 (ByteString)
import TcRnMonad (initTcRnIf)
import IDE.Utils.GHCUtils
import Control.DeepSeq(deepseq)


collectPackageFromHI :: PackageConfig -> IO PackageDescr
collectPackageFromHI  packageConfig = inGhcIO [] [] $ \ _ -> do
    session             <-  getSession
    exportedIfaceInfos  <-  getIFaceInfos (getThisPackage packageConfig)
                                            (IPI.exposedModules packageConfig) session
    hiddenIfaceInfos    <-  getIFaceInfos (getThisPackage packageConfig)
                                            (IPI.hiddenModules packageConfig) session
    let pd = extractInfo exportedIfaceInfos hiddenIfaceInfos (getThisPackage packageConfig)
#if MIN_VERSION_Cabal(1,8,0)
                                            [] -- TODO 6.12 (IPI.depends $ packageConfigToInstalledPackageInfo packageConfig))
#else
				            (depends packageConfig)
#endif
    deepseq pd (return pd)


getIFaceInfos :: PackageIdentifier -> [Module.ModuleName] -> HscEnv -> Ghc [(ModIface, FilePath)]
getIFaceInfos pid modules _session = do
    let isBase          =   pkgName pid == (PackageName "base")
    let ifaces          =   mapM (\ mn -> findAndReadIface empty
                                          (if isBase
                                                then mkBaseModule_ mn
                                                else mkModule (mkPackageId pid) mn)
                                          False) modules
    hscEnv              <-  getSession
    let gblEnv          =   IfGblEnv { if_rec_types = Nothing }
    maybes              <-  Hs.liftIO $ initTcRnIf  'i' hscEnv gblEnv () ifaces
    let res             =   catMaybes (map handleErr maybes)
    return res
    where
        handleErr (M.Succeeded val)   =   Just val
        handleErr (M.Failed _mess)    =   Nothing

-------------------------------------------------------------------------

extractInfo :: [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdentifier ->
                    [PackageIdentifier] -> PackageDescr
extractInfo  ifacesExp ifacesHid pid buildDepends =
    let allDescrs           =   concatMap (extractExportedDescrH pid)
                                    (map fst (ifacesHid ++ ifacesExp))
        mods                =   map (extractExportedDescrR pid allDescrs) (map fst ifacesExp)
    in PackageDescr {
        pdPackage           =   pid
    ,   pdModules           =   mods
    ,   pdBuildDepends      =   buildDepends
    ,   pdMbSourcePath      =   Nothing}

extractExportedDescrH :: PackageIdentifier -> ModIface -> [Descr]
extractExportedDescrH pid iface =
    let mid                 =   (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface)
        exportedNames       =   Set.fromList
#if MIN_VERSION_Cabal(1,11,0)
                                $ map (occNameString . nameOccName)
                                    $ concatMap availNames
                                        $ mi_exports iface
#else
                                $ map occNameString
                                    $ concatMap availNames
                                        $ concatMap snd (mi_exports iface)
#endif
        exportedDecls       =   filter (\ ifdecl -> (occNameString $ ifName ifdecl)
                                                    `Set.member` exportedNames)
                                                            (map snd (mi_decls iface))
    in  concatMap (extractIdentifierDescr pid [mid]) exportedDecls


extractExportedDescrR :: PackageIdentifier
    -> [Descr]
    -> ModIface
    -> ModuleDescr
extractExportedDescrR pid hidden iface =
    let mid             =   (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface)
        exportedNames   =   Set.fromList
#if MIN_VERSION_Cabal(1,11,0)
                                $ map (occNameString . nameOccName)
                                    $ concatMap availNames
                                        $ mi_exports iface
#else
                                $ map occNameString
                                    $ concatMap availNames
                                        $ concatMap snd (mi_exports iface)
#endif
        exportedDecls   =   filter (\ ifdecl -> (occNameString $ifName ifdecl)
                                                    `Set.member` exportedNames)
                                                            (map snd (mi_decls iface))
        ownDecls        =   concatMap (extractIdentifierDescr pid [mid]) exportedDecls
        otherDecls      =   exportedNames `Set.difference` (Set.fromList (map dscName ownDecls))
        reexported      =   map (\d -> Reexported (ReexportedDescr (Just (PM pid mid)) d))
                                 $ filter (\k -> (dscName k) `Set.member` otherDecls) hidden
        inst            =   concatMap (extractInstances (PM pid mid)) (mi_insts iface)
        uses            =   Map.fromList . catMaybes $ map extractUsages (mi_usages iface)
        declsWithExp    =   map withExp ownDecls
        withExp (Real d) =  Real $ d{dscExported' = Set.member (dscName' d) exportedNames}
        withExp _        =  error "Unexpected Reexported"
    in  ModuleDescr {
                    mdModuleId          =   PM pid mid
                ,   mdMbSourcePath      =   Nothing
                ,   mdReferences        =   uses
                ,   mdIdDescriptions    =   declsWithExp ++ inst ++ reexported}

extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl -> [Descr]
extractIdentifierDescr package modules decl
   = if null modules
      then []
      else
        let descr = RealDescr{
                    dscName'           =   unpackFS $occNameFS (ifName decl)
                ,   dscMbTypeStr'      =   Just (BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual $ppr decl)
                ,   dscMbModu'         =   Just (PM package (last modules))
                ,   dscMbLocation'     =   Nothing
                ,   dscMbComment'      =   Nothing
                ,   dscTypeHint'       =   VariableDescr
                ,   dscExported'       =   True
                }
        in case decl of
#if MIN_VERSION_Cabal(1,8,0)
            (IfaceId _ _ _ _)
#else
            (IfaceId _ _ _)
#endif
                -> map Real [descr]
#if MIN_VERSION_Cabal(1,11,0)
            (IfaceData name _ _ ifCons' _ _ _)
#else
            (IfaceData name _ _ ifCons' _ _ _ _)
#endif
                -> let d = case ifCons' of
                            IfDataTyCon _decls
                                ->  let
                                        fieldNames          =   concatMap extractFields (visibleIfConDecls ifCons')
                                        constructors'       =   extractConstructors name (visibleIfConDecls ifCons')
                                    in DataDescr constructors' fieldNames
                            IfNewTyCon _
                                ->  let
                                        fieldNames          =   concatMap extractFields (visibleIfConDecls ifCons')
                                        constructors'       =   extractConstructors name (visibleIfConDecls ifCons')
                                        mbField             =   case fieldNames of
                                                                    [] -> Nothing
                                                                    [fn] -> Just fn
                                                                    _ -> error $ "InterfaceCollector >> extractIdentifierDescr: "
                                                                         ++ "Newtype with more then one field"
                                        constructor         =   case constructors' of
                                                                    [c] -> c
                                                                    _ -> error $ "InterfaceCollector >> extractIdentifierDescr: "
                                                                         ++ "Newtype with not exactly one constructor"
                                    in NewtypeDescr constructor mbField
#if MIN_VERSION_ghc(7,3,0)
                            IfAbstractTyCon _ ->  DataDescr [] []
#else
                            IfAbstractTyCon ->  DataDescr [] []
#endif
                            IfOpenDataTyCon ->  DataDescr [] []
                    in [Real (descr{dscTypeHint' = d})]
            (IfaceClass context _ _ _ _ ifSigs' _ )
                        ->  let
                                classOpsID          =   map extractClassOp ifSigs'
                                superclasses        =   extractSuperClassNames context
                            in [Real $ descr{dscTypeHint' = ClassDescr superclasses classOpsID}]
            (IfaceSyn _ _ _ _ _ )
                        ->  [Real $ descr{dscTypeHint' = TypeDescr}]
            (IfaceForeign _ _)
                        ->  [Real $ descr]

extractConstructors ::   OccName -> [IfaceConDecl] -> [SimpleDescr]
extractConstructors name decls    =   map (\decl -> SimpleDescr (unpackFS $occNameFS (ifConOcc decl))
                                                 (Just (BS.pack $ filterExtras $ showSDocUnqual $
                                                    pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl)
                                                        (eq_ctxt decl ++ ifConCtxt decl) (pp_tau decl)))
                                                 Nothing Nothing True) decls

    where
    pp_tau decl     = case map pprParendIfaceType (ifConArgTys decl) ++ [pp_res_ty decl] of
                    		(t:ts) -> fsep (t : map (arrow <+>) ts)
                    		[]     -> panic "pp_con_taus"
    pp_res_ty decl  = ppr name <+> fsep [ppr tv | (tv,_) <- ifConUnivTvs decl]
#if MIN_VERSION_ghc(7,3,0)
    eq_ctxt decl    = [IfaceTyConApp (IfaceTc eqTyConName) [(IfaceTyVar (occNameFS tv)), ty]
#else
    eq_ctxt decl    = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
#endif
	                        | (tv,ty) <- ifConEqSpec decl]

extractFields ::  IfaceConDecl -> [SimpleDescr]
extractFields  decl    =   map (\ (n, t) -> SimpleDescr n t Nothing Nothing True)
                                $ zip (map extractFieldNames (ifConFields decl))
                                        (map extractType (ifConArgTys decl))

extractType :: IfaceType -> Maybe ByteString
extractType it = Just ((BS.pack . filterExtras . showSDocUnqual . ppr) it)

extractFieldNames :: OccName -> String
extractFieldNames occName = unpackFS $occNameFS occName

extractClassOp :: IfaceClassOp -> SimpleDescr
extractClassOp (IfaceClassOp occName _dm ty) = SimpleDescr (unpackFS $occNameFS occName)
                                                (Just (BS.pack $ showSDocUnqual (ppr ty)))
                                                Nothing Nothing True

extractSuperClassNames :: [IfacePredType] -> [String]
extractSuperClassNames l = catMaybes $ map extractSuperClassName l
    where
#if !MIN_VERSION_ghc(7,3,0)
            extractSuperClassName (IfaceClassP name _)  =
                Just (unpackFS $occNameFS $ nameOccName name)
#endif
            extractSuperClassName _                     =   Nothing

extractInstances :: PackModule -> IfaceInst -> [Descr]
extractInstances pm ifaceInst  =
    let className   =   showSDocUnqual $ ppr $ ifInstCls ifaceInst
        dataNames   =   map (\iftc -> showSDocUnqual $ ppr iftc)
                            $ map fromJust
                                $ filter isJust
                                    $ ifInstTys ifaceInst
    in [Real (RealDescr
                    {   dscName'         =   className
                    ,   dscMbTypeStr'    =   Nothing
                    ,   dscMbModu'       =   Just pm
                    ,   dscMbLocation'   =   Nothing
                    ,   dscMbComment'    =   Nothing
                    ,   dscTypeHint'     =   InstanceDescr dataNames
                    ,   dscExported'     =   False})]


extractUsages :: Usage -> Maybe (ModuleName, Set String)
#if MIN_VERSION_Cabal(1,11,0)
extractUsages (UsagePackageModule usg_mod' _ _) =
#else
extractUsages (UsagePackageModule usg_mod' _ ) =
#endif
    let name    =   (fromJust . simpleParse . moduleNameString) (moduleName usg_mod')
    in Just (name, Set.fromList [])
#if MIN_VERSION_Cabal(1,11,0)
extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _ _) =
#else
extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _) =
#endif
    let name    =   (fromJust . simpleParse . moduleNameString) usg_mod_name'
        ids     =   map (showSDocUnqual . ppr . fst) usg_entities'
    in Just (name, Set.fromList ids)
#if MIN_VERSION_ghc(7,4,0)
extractUsages (UsageFile _ _) = Nothing
#endif

filterExtras, filterExtras' :: String -> String
filterExtras ('{':'-':r)                =   filterExtras' r
filterExtras ('R':'e':'c':'F':'l':'a':'g':r)
                                        =   filterExtras (skipNextWord r)
filterExtras ('G':'e':'n':'e':'r':'i':'c':'s':':':r)
                                        =   filterExtras (skipNextWord r)
filterExtras ('F':'a':'m':'i':'l':'y':'I':'n':'s':'t':'a':'n':'c':'e':':':r)
                                        =   filterExtras (skipNextWord r)
filterExtras (c:r)                      =   c : filterExtras r
filterExtras []                         =   []

filterExtras' ('-':'}':r)   =   filterExtras r
filterExtras' (_:r)         =   filterExtras' r
filterExtras' []            =   []

skipNextWord, skipNextWord' :: String -> String
skipNextWord (a:r)
    | isSpace a             =   skipNextWord r
    | otherwise             =   skipNextWord' r
skipNextWord []             =   []

skipNextWord'(a:r)
        | a == '\n'          =   r
        | isSpace a         =   a:r
        | otherwise         =   skipNextWord' r
skipNextWord' []            =   []