-----------------------------------------------------------------------------
--
-- Module      :  IDE.Metainfo.SourceDB
-- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GPL
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module IDE.Metainfo.SourceDB (

    buildSourceForPackageDB
,   sourceForPackage
,   parseSourceForPackageDB
,   getSourcesMap

) where

import IDE.StrippedPrefs
       (getUnpackDirectory, getSourceDirectories, Prefs(..))
import Data.Map (Map)
import Distribution.Package (PackageIdentifier(..))
import IDE.Utils.Utils (standardSourcesFilename)
import qualified Data.Map as Map
       (fromList, toList, fromListWith, lookup)
import IDE.Utils.FileUtils
       (myCanonicalizePath, getConfigFilePathForLoad,
        getConfigFilePathForSave, allCabalFiles)
import System.Directory (doesFileExist)
import Data.List (foldl')
import qualified Text.PrettyPrint as PP
       (colon, (<>), text, ($$), vcat, Doc, render, char)
import Text.ParserCombinators.Parsec
       (try, char, unexpected, noneOf, eof, many, CharParser,
        parseFromFile, (<?>), (<|>))
import Text.ParserCombinators.Parsec.Language (emptyDef)
#if MIN_VERSION_parsec(3,0,0)
import qualified Text.ParserCombinators.Parsec.Token as P
       (GenTokenParser(..), TokenParser, makeTokenParser, commentLine,
        commentEnd, commentStart, LanguageDef)
#else
import qualified Text.ParserCombinators.Parsec.Token as P
       (TokenParser(..), makeTokenParser, commentLine,
        commentEnd, commentStart, LanguageDef)
#endif
import Data.Maybe (catMaybes)
import IDE.Core.CTypes (packageIdentifierFromString)
import Paths_leksah_server
import System.Log.Logger(errorM,debugM)

-- ---------------------------------------------------------------------
-- 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 ->  error "can't build/open source for package file"

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

buildSourceForPackageDB :: Prefs -> IO ()
buildSourceForPackageDB prefs = do
    sourceDirs <- getSourceDirectories prefs
    unpackDir  <- getUnpackDirectory prefs
    let dirs        =   case unpackDir of
                            Just dir -> dir : sourceDirs
                            Nothing ->  sourceDirs
    cabalFiles      <-  mapM allCabalFiles dirs
    fCabalFiles     <-  mapM myCanonicalizePath $ concat cabalFiles
    mbPackAndFiles  <-  mapM (\fp -> do
                                mb <- parseCabal fp
                                case mb of
                                    Just s  -> return $ Just (s, [fp])
                                    Nothing -> return Nothing) fCabalFiles
    let pdToFiles   =   Map.fromListWith (++) $ catMaybes mbPackAndFiles
    filePath        <-  getConfigFilePathForSave standardSourcesFilename
    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
    dataDir         <-  getDataDir
    filePath        <-  getConfigFilePathForLoad standardSourcesFilename Nothing dataDir
    exists          <-  doesFileExist filePath
    if exists
        then do
            res             <-  parseFromFile sourceForPackageParser filePath
            case res of
                Left pe ->  do
                    errorM "leksah-server" $ "Error reading source packages file "
                            ++ filePath ++ " " ++ show pe
                    return Nothing
                Right r ->  return (Just r)
        else do
            errorM "leksah-server" $" No source packages file found: " ++ filePath
            return Nothing

--
-- ---------------------------------------------------------------------
-- | Parser for Package DB
--
packageStyle  :: P.LanguageDef st
packageStyle  = emptyDef
                { P.commentStart   = "{-"
                , P.commentLine    = "--"
                , P.commentEnd     = "-}"
                }

lexer :: P.TokenParser st
lexer = P.makeTokenParser packageStyle

whiteSpace :: CharParser st ()
whiteSpace = P.whiteSpace lexer

symbol :: String -> CharParser st String
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 (packageIdentifierFromString 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
            errorM "leksah-server" $"Error reading cabal file " ++ show fn ++ " " ++ show pe
            return Nothing
        Right r ->  do
            debugM "leksah-server" 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
            versionString    <-  (many $noneOf " \n")
            (many $noneOf "\n")
            char '\n'
            return (Left versionString)
    <|> do
            many $noneOf "\n"
            char '\n'
            cabalMinimalP
    <?> "cabal minimal"