{-# OPTIONS_GHC -XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Metainfo.SourceCollector
-- Copyright   :  (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GNU-GPL
--
-- Maintainer  :  <maintainer at leksah.org>
-- Stability   :  provisional
-- Portability :  portable
--
-- | This module collects information for packages with source available
--
-------------------------------------------------------------------------------

module IDE.Metainfo.SourceCollector (
    collectSources
,   buildSourceForPackageDB
,   sourceForPackage
,   parseSourceForPackageDB
,   getSourcesMap
) where

import qualified Text.PrettyPrint.HughesPJ as PP
import qualified Data.Map as Map
import Data.Map (Map)
import Distribution.PackageDescription
import Distribution.Verbosity
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(emptyDef)
import System.Directory
import Control.Monad.State
import System.FilePath
import System.IO
import Data.List (foldl',nub,delete,sort)
import Data.Maybe(catMaybes)
import qualified Data.ByteString.Char8 as BS


import GHC hiding (idType)
import SrcLoc
import RdrName
import OccName
import DynFlags
import StringBuffer
import Bag
import ErrUtils
import FastString
import Outputable hiding (char)

import IDE.Core.State
import IDE.FileUtils
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription.Parse (readPackageDescription)
import GHC.Exception (SomeException(..))
import Distribution.Package (PackageIdentifier(..))
import Distribution.Text (display)
import DriverPipeline (preprocess)
import GHC.Show (showSpace)
import IDE.Metainfo.GHCUtils (myParseModule)


-- ---------------------------------------------------------------------
-- | Collect infos from sources for one package
--
collectSources :: Map PackageIdentifier [FilePath]
    -> PackageDescr
    -> Ghc (PackageDescr,Int)
collectSources sourceMap pdescr = do
    sysMessage Normal $ "Now collecting sources for " ++ display (packagePD pdescr)
    case sourceForPackage (packagePD pdescr) sourceMap of
        Nothing -> do
            sysMessage Normal $ "No source for package " ++ display (packagePD pdescr)
            return (pdescr,0)
        Just cabalPath -> gcatch (do
            let basePath    =   normalise $ (takeDirectory cabalPath)
            pkgDescr        <-  gcatch (liftIO $  (liftM flattenPackageDescription
                                        (readPackageDescription silent cabalPath)))
                                    (\(e :: SomeException) -> return emptyPackageDescription)
            let bis         =   allBuildInfo pkgDescr
            let buildPaths  =   if hasExes pkgDescr
                                then let exeName' = exeName (head (executables pkgDescr))
                                     in  map (\p -> basePath </> p) $
                                        ("dist" </> "build" </> exeName' </>
                                                    exeName' ++ "-tmp" </> "") :
                                        ("dist" </> "build" </> "autogen") : (".")
                                                : (nub $ concatMap hsSourceDirs bis)
                                else map (\p -> basePath </> p) $
                                        ("dist" </> "build" </> "autogen") : (".")
                                                : (nub $ concatMap hsSourceDirs bis)
            let includes    =    map (\p -> basePath </> p)  $ nub $ concatMap includeDirs bis

            dflags             <-  getSessionDynFlags
            let dflags2 = dflags {
                topDir    = basePath,
                hscTarget = HscNothing,
                ghcMode   = CompManager,
                ghcLink   = NoLink}
            setSessionDynFlags dflags2
            let flags       =         ["-fglasgow-exts"]
                                    ++ ["-cpp"]
                                    ++ ["-w"]
                                    ++ ["-I" ++ dir | dir <- includes]
                                    ++ ["-I" ++ dir | dir <- buildPaths]
                                    ++ ["-i" ++ dir | dir <- includes]
                                    ++ ["-i" ++ dir | dir <- buildPaths]
                                    ++ ["-X" ++ show e | e <- nub $ concatMap extensions bis]
            -- trace ("flags " ++ show flags) $ return ()
            dflags3          <-  getSessionDynFlags
            (dflags4,_,_)   <-  parseDynamicFlags dflags3 (map noLoc flags)
            let dflags5     =   dopt_set (dopt_set dflags4 Opt_Haddock) Opt_ReadUserPackageConf
            setSessionDynFlags dflags5

            let allMods     =  nub (exeModules pkgDescr ++ libModules pkgDescr)
            let exposedMods =   map (modu . moduleIdMD) (exposedModulesPD pdescr)
            sourceFiles     <-  liftIO $ mapM (findSourceFile
                                                    buildPaths
                                                    ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"])
                                                    $ nub (exposedMods ++ allMods)
            (newModDescrs,failureCount)
                            <-  foldM collectSourcesForModule ([],0)
                                                (zip (exposedModulesPD pdescr) sourceFiles)
            let nPackDescr  =   pdescr{mbSourcePathPD = Just cabalPath,
                                            exposedModulesPD = newModDescrs}
            return (nPackDescr,failureCount))
            (\(e :: SomeException) -> do
                sysMessage Normal $ "source collector throwIDE1 " ++ show e ++ " in " ++
                            display (packagePD pdescr) ++ " missed "
                                ++ show (length $ exposedModulesPD pdescr)
                return (pdescr,length $ exposedModulesPD pdescr))

-- ---------------------------------------------------------------------
-- | Collect infos from sources for one module
--
collectSourcesForModule :: ([ModuleDescr],Int)
    -> (ModuleDescr, Maybe FilePath)
    -> Ghc ([ModuleDescr],Int)
collectSourcesForModule (moduleDescrs,failureCount) (moduleDescr,mbfp) =
    case mbfp of
        Nothing ->  do
            sysMessage Normal $ "No source for module " ++ (display $ modu $ moduleIdMD moduleDescr)
            return(moduleDescr : moduleDescrs, failureCount+1)
        Just fp ->  do
            session <- getSession
            (_,fp')          <-  preprocess session (fp,Nothing)
            dynFlags        <-  getSessionDynFlags
            liftIO $ do
                stringBuffer    <-  hGetStringBuffer fp'
                parseResult     <-  myParseModule dynFlags fp' (Just stringBuffer)
                let newModD     =   moduleDescr{mbSourcePathMD = mbfp}
                case parseResult of
                    Right (L _ (HsModule _ _ _ decls _ _ _ )) -> do
                        let map'                =   convertToMap (idDescriptionsMD newModD)
                        let commentedDecls      =   addComments (filterSignatures decls)
                        let (descrs,restMap)    =   foldl collectParseInfoForDecl ([],map')
                                                        commentedDecls
                        let newModD'            =   newModD{
                            idDescriptionsMD    =   reverse descrs ++ concat (Map.elems restMap)}
                        return(newModD' : moduleDescrs, failureCount)
                    Left errMsg -> do
                        sysMessage Normal $ "Failed to parse " ++ fp
                        printBagOfErrors defaultDynFlags (unitBag errMsg)
                        return (newModD : moduleDescrs, failureCount+1)
    where
        convertToMap :: [Descr] -> Map Symbol [Descr]
        convertToMap  list  =
         foldl' (\ st idDescr -> Map.insertWith (++) (descrName idDescr) [idDescr] st)
            Map.empty list
        convertFromMap :: Map Symbol [Descr]  -> [Descr]
        convertFromMap      =   concat . Map.elems


filterSignatures :: [LHsDecl RdrName] -> [LHsDecl RdrName]
filterSignatures declList = filter filterSignature declList
    where
    filterSignature (L srcDecl (SigD _)) = False
    filterSignature _ = True

addComments :: [LHsDecl RdrName] -> [(Maybe (LHsDecl RdrName), Maybe String)]
addComments = reverse . snd . foldl' addComment (Nothing,[])
    where
    addComment :: (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)])
        ->  LHsDecl RdrName
        -> (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)])
    addComment (maybeComment,((Just decl,Nothing):r)) (L srcDecl (DocD (DocCommentPrev doc))) =
        (Nothing,((Just decl,Just (printHsDoc doc)):r))
    addComment other (L srcDecl (DocD (DocCommentPrev doc))) =
        other
    addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNext doc))) =
        (Just (printHsDoc doc),resultList)
    addComment (maybeComment,resultList) (L srcDecl (DocD (DocGroup i doc))) =
        (Nothing,(((Nothing,Just (printHsDoc doc)): resultList)))
    addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNamed str doc))) =
        (Nothing,resultList)
    addComment (Nothing,resultList) decl = (Nothing,(Just decl,Nothing):resultList)
    addComment (Just comment,resultList) decl =  (Nothing,(Just decl,Just comment):resultList)

collectParseInfoForDecl ::  ([Descr],SymbolTable)
    -> (Maybe (LHsDecl RdrName),Maybe String)
    -> ([Descr],SymbolTable)
collectParseInfoForDecl (l,st) (Just (L loc _),_) | not (isGoodSrcSpan loc) = (l,st)
collectParseInfoForDecl (l,st) ((Just (L loc (ValD (FunBind lid _ _ _ _ _)))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Variable] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyData _ _ lid _ _ _ _ _)))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TySynonym lid _ _ _)))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Type] []
collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment')
    =   addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] []
collectParseInfoForDecl (l,st) ((Just (L loc (InstD (InstDecl lid binds sigs cldecl)))), mbComment')
    =   case unLoc lid of
            HsForAllTy	_ _ _ e ->
                case unLoc e of
                    HsPredTy p       ->
                        case p of
                            HsClassP n types
                                -> --trace ("name: " ++ unpackFS (occNameFS (rdrNameOcc n)) ++ "\n" ++
                                          --"binds : " ++ showSDocUnqual (ppr binds) ++ "\n" ++
                                          --"sigs : " ++ showSDocUnqual (ppr sigs) ++ "\n" ++
                                          --"cldecl : " ++ showSDocUnqual (ppr cldecl) ++ "\n" ++
                                   --       "types : " ++ showSDocUnqual (ppr types)) $
                                   addLocationAndComment (l,st) n loc mbComment' [Instance]
                                            (map (\t -> analyse (unLoc t)) types)
                            _   -> trace ("lid3:Other") (l,st)
                    _                   -> trace "lid2:Other"    (l,st)
            _                   -> trace "lid:Other"    (l,st)
    where
    analyse (HsTyVar n)             =   unpackFS (occNameFS (rdrNameOcc n))
    analyse (HsForAllTy n _ _ _)    =   trace "lid5:For all" ""
    analyse _                       =   trace "lid5:Other" ""
collectParseInfoForDecl (l,st) (Just decl,mbComment')
    =   {--trace (declTypeToString (unLoc decl) ++ "--" ++ (showSDocUnqual $ppr decl))--} (l,st)
collectParseInfoForDecl (l,st) (Nothing, mbComment')    =
    {--trace ("Found comment " ++ show mbComment')--} (l,st)


addLocationAndComment :: ([Descr],SymbolTable)
    -> RdrName
    -> SrcSpan
    -> Maybe String
    -> [DescrType]
    -> [String]
    -> ([Descr],SymbolTable)
addLocationAndComment (l,st) lid srcSpan mbComment' types insts =
    let occ         =   rdrNameOcc lid
        name        =   unpackFS (occNameFS occ)
        mbItems     =   Map.lookup name st
        (mbItem,nst)=   case mbItems of
                            Nothing     -> (Nothing,st)

                            Just [i]    ->  (Just i, Map.delete name st)
                            Just list   ->
                                case filter (\i -> matches i types insts) list of
                                    []  ->  (Nothing,st)
                                    l'  ->  (Just (head l'),
                                                Map.adjust (\li -> delete (head l') li)
                                                    name st)
    in case mbItem of
        Just identDescr |not (isReexported identDescr)    ->  (identDescr{
                mbLocation'  =   Just (srcSpanToLocation srcSpan),
                mbComment'   =   case mbComment' of
                                    Nothing -> Nothing
                                    Just s -> Just (BS.pack s)}
                                     : l, nst)
        otherwise           ->  (l,st)

    where
    matches :: Descr -> [DescrType] -> [String] -> Bool
    matches idDescr idTypes inst =
        case descrType (details idDescr) of
            Instance ->
                --trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $
                elem Instance idTypes && sort (binds (details idDescr)) == sort inst
            other   -> elem other idTypes

declTypeToString :: Show alpha => HsDecl alpha -> String
declTypeToString  (TyClD	_)   =   "TyClD"
declTypeToString  (InstD _)   =   "InstD"
declTypeToString  (DerivD _)  =   "DerivD"
declTypeToString  (ValD	_)    =   "ValD"
declTypeToString  (SigD _)    =   "SigD"
declTypeToString  (DefD _)    =   "DefD"
declTypeToString  (ForD _)    =   "ForD"
declTypeToString  (WarningD _)=  "WarnD"
declTypeToString  (RuleD _)   =   "RuleD"
declTypeToString  (SpliceD _) = "SpliceD"
declTypeToString  (DocD v)    =   "DocD " ++ show v

srcSpanToLocation :: SrcSpan -> Location
srcSpanToLocation span | not (isGoodSrcSpan span)
    =   throwIDE "srcSpanToLocation: unhelpful span"
srcSpanToLocation span
    =   Location (srcSpanStartLine span) (srcSpanStartCol span)
                 (srcSpanEndLine span) (srcSpanEndCol span)

printHsDoc :: Show alpha => HsDoc alpha  -> String
printHsDoc d = show (PPDoc d)

newtype PPDoc alpha = PPDoc (HsDoc alpha)

instance Show alpha => Show (PPDoc alpha)  where
    showsPrec _ (PPDoc DocEmpty)                 =   id
    showsPrec _ (PPDoc (DocAppend l r))          =   shows (PPDoc l)  . shows (PPDoc r)
    showsPrec _ (PPDoc (DocString str))          =   showString str
    showsPrec _ (PPDoc (DocParagraph d))         =   shows (PPDoc d) . showChar '\n'
    showsPrec _ (PPDoc (DocIdentifier l))        =   foldr (\i f -> showChar '\'' . shows i . showChar '\'') id l
    showsPrec _ (PPDoc (DocModule str))          =   showChar '"' . showString str . showChar '"'
    showsPrec _ (PPDoc (DocEmphasis doc))        =   showChar '/' . shows (PPDoc doc)  . showChar '/'
    showsPrec _ (PPDoc (DocMonospaced doc))      =   showChar '@' . shows (PPDoc doc) . showChar '@'
    showsPrec _ (PPDoc (DocUnorderedList l))     =
        foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l
    showsPrec _ (PPDoc (DocOrderedList l))       =
        foldr (\(i,n) f -> shows n . showSpace .  shows (PPDoc i)) id (zip l [1 .. length l])
    showsPrec _ (PPDoc (DocDefList li))          =
        foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li
    showsPrec _ (PPDoc (DocCodeBlock doc))      =   showChar '@' . shows (PPDoc doc) . showChar '@'
    showsPrec _ (PPDoc (DocURL str))            =   showChar '<' . showString str . showChar '>'
    showsPrec _ (PPDoc (DocAName str))          =   showChar '#' . showString str . showChar '#'
    showsPrec _ (PPDoc _)                       =   id

instance Show RdrName where
    show                                =   unpackFS . occNameFS . rdrNameOcc

instance Show alpha => Show (DocDecl alpha) where
        show  (DocCommentNext doc)      =       "DocCommentNext " ++ show doc
        show  (DocCommentPrev doc)      =       "DocCommentPrev " ++ show doc
        show  (DocCommentNamed str doc) =       "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc
        show  (DocGroup i doc)          =       "DocGroup" ++ " " ++ show i ++ " " ++ show doc

unloadGhc :: Ghc ()
unloadGhc = do
   setTargets []
   load LoadAllTargets
   return ()


-- ---------------------------------------------------------------------
-- Function to map packages to file paths
--

getSourcesMap :: Prefs -> IO (Map PackageIdentifier [FilePath])
getSourcesMap prefs = do
        mbSources <- parseSourceForPackageDB
        case mbSources of
            Just map -> return map
            Nothing -> do
                buildSourceForPackageDB prefs
                mbSources <- parseSourceForPackageDB
                case mbSources of
                    Just map -> do
                        return map
                    Nothing ->  throwIDE "can't build/open source for package file"

sourceForPackage :: PackageIdentifier
    -> (Map PackageIdentifier [FilePath])
    -> Maybe FilePath
sourceForPackage id map =
    case id `Map.lookup` map of
        Just (h:_)  ->  Just h
        _           ->  Nothing

buildSourceForPackageDB :: Prefs -> IO ()
buildSourceForPackageDB prefs = do
    case autoExtractTars prefs of
        Nothing     -> return ()
        Just path   -> do
            dir <- getCurrentDirectory
            autoExtractTarFiles path
            setCurrentDirectory dir
    let dirs        =   sourceDirectories prefs
    cabalFiles      <-  mapM allCabalFiles dirs
    fCabalFiles     <-  mapM canonicalizePath $ concat cabalFiles
    mbPackages      <-  mapM (\fp -> parseCabal fp) fCabalFiles
    let pdToFiles   =   Map.fromListWith (++)
                $ map (\(Just p,o ) -> (p,o))
                    $ filter (\(mb, _) -> case mb of
                                            Nothing -> False
                                            _       -> True )
                        $ zip mbPackages (map (\a -> [a]) fCabalFiles)
    filePath        <-  getConfigFilePathForSave "source_packages.txt"
    writeFile filePath  (PP.render (showSourceForPackageDB pdToFiles))

showSourceForPackageDB  :: Map String [FilePath] -> PP.Doc
showSourceForPackageDB aMap = PP.vcat (map showIt (Map.toList aMap))
    where
    showIt :: (String,[FilePath]) -> PP.Doc
    showIt (pd,list) =  (foldl' (\l n -> l PP.$$ (PP.text $ show n)) label list)
                             PP.<>  PP.char '\n'
        where label  =  PP.text pd PP.<> PP.colon

parseSourceForPackageDB :: IO (Maybe (Map PackageIdentifier [FilePath]))
parseSourceForPackageDB = do
    filePath        <-  getConfigFilePathForLoad "source_packages.txt"
    exists          <-  doesFileExist filePath
    if exists
        then do
            res             <-  parseFromFile sourceForPackageParser filePath
            case res of
                Left pe ->  do
                    sysMessage Normal $"Error reading source packages file "
                            ++ filePath ++ " " ++ show pe
                    return Nothing
                Right r ->  return (Just r)
        else do
            sysMessage Normal $"No source packages file found: " ++ filePath
            return Nothing

---- Returns the package name as a string (e.g. ohohoh-0.1.0)
--parseCabal :: FilePath -> IO (Maybe String)
--parseCabal cabalPath = gcatch (do
--    gpd <- readPackageDescription silent cabalPath
--    return (Just ((display . package . packageDescription) gpd)))
--        $ \ (e :: SomeException) -> do
--            sysMessage Normal ("SourceCollector>>parseCabal:Can't parse cabal " ++ show e)
--            return Nothing
--
-- ---------------------------------------------------------------------
-- | Parser for Package DB
--
packageStyle  :: P.LanguageDef st
packageStyle  = emptyDef
                { P.commentStart   = "{-"
                , P.commentEnd     = "-}"
                , P.commentLine    = "--"
                }

lexer       =   P.makeTokenParser packageStyle
whiteSpace  =   P.whiteSpace lexer
symbol      =   P.symbol lexer

sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath])
sourceForPackageParser = do
    whiteSpace
    ls  <-  many onePackageParser
    whiteSpace
    eof
    return (Map.fromList (catMaybes ls))
    <?> "sourceForPackageParser"

onePackageParser :: CharParser () (Maybe (PackageIdentifier,[FilePath]))
onePackageParser = do
    mbPd        <-  packageDescriptionParser
    filePaths   <-  many filePathParser
    case mbPd of
        Nothing -> return Nothing
        Just pd -> return (Just (pd,filePaths))
    <?> "onePackageParser"

packageDescriptionParser :: CharParser () (Maybe PackageIdentifier)
packageDescriptionParser = try (do
    whiteSpace
    str <- many (noneOf ":")
    char ':'
    return (toPackageIdentifier str))
    <?> "packageDescriptionParser"

filePathParser :: CharParser () FilePath
filePathParser = try (do
    whiteSpace
    char '"'
    str <- many (noneOf ['"'])
    char '"'
    return (str))
    <?> "filePathParser"

parseCabal :: FilePath -> IO (Maybe String)
parseCabal fn = do
    --putStrLn $ "Now parsing minimal " ++ fn
    res     <-  parseFromFile cabalMinimalParser fn
    case res of
        Left pe ->  do
            sysMessage Normal $"Error reading cabal file " ++ show fn ++ " " ++ show pe
            return Nothing
        Right r ->  do
            sysMessage Normal r
            return (Just r)

cabalMinimalParser :: CharParser () String
cabalMinimalParser = do
    r1 <- cabalMinimalP
    r2 <- cabalMinimalP
    case r1 of
        Left v -> do
            case r2 of
                Right n -> return (n ++ "-" ++ v)
                Left _ -> unexpected "Illegal cabal"
        Right n -> do
            case r2 of
                Left v -> return (n ++ "-" ++ v)
                Right _ -> unexpected "Illegal cabal"

cabalMinimalP :: CharParser () (Either String String)
cabalMinimalP =
    do  try $(symbol "name:" <|> symbol "Name:")
        whiteSpace
        name       <-  (many $noneOf " \n")
        (many $noneOf "\n")
        char '\n'
        return (Right name)
    <|> do
            try $(symbol "version:" <|> symbol "Version:")
            whiteSpace
            version    <-  (many $noneOf " \n")
            (many $noneOf "\n")
            char '\n'
            return (Left version)
    <|> do
            many $noneOf "\n"
            char '\n'
            cabalMinimalP
    <?> "cabal minimal"