module UHC.Light.Compiler.Base.PackageDatabase
( pkgDbLookup
, pkgWritePkgOptionAsCfg
, pkgDbFromDirs
, pkgDbSelectBySearchFilter
, PkgModulePartition
, pkgPartInclDirs
, pkgExposedPackages
, pkgDbFreeze
, fileLocSearch )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Error
import qualified UHC.Light.Compiler.Config as Cfg
import UU.Parsing
import UHC.Util.ParseUtils
import UHC.Light.Compiler.Base.Parser2
import UHC.Util.ScanUtils
import UHC.Light.Compiler.Scanner.Common
import UHC.Light.Compiler.Base.HsName
import UHC.Light.Compiler.Base.ParseUtils
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Version
import Data.List
import Data.Maybe
import Data.Char
import System.Environment
import System.Directory
import Control.Monad
import Control.Monad.State
import System.IO
import System.Exit
import System.Environment
import UHC.Util.FPath
import UHC.Util.Utils
import UHC.Util.Debug

{-# LINE 50 "src/ehc/Base/PackageDatabase.chs" #-}
-- | The config file name, wrapped inside a Maybe when it can indeed be created
pkgCfgFPath :: Bool -> FPath -> IO (Maybe (FPath, FilePath))
pkgCfgFPath createIfAbsent pkgfp = do
    when createIfAbsent $ createDirectoryIfMissing True pkgdir
    isDir <- doesDirectoryExist pkgdir		-- remove this...??
    if isDir
      then return $ Just (fpathSetDir pkgdir $ fpathFromStr Cfg.ehcPkgConfigfileName, pkgdir)
      else return Nothing
  where pkgdir = fpathToStr pkgfp

{-# LINE 66 "src/ehc/Base/PackageDatabase.chs" #-}
-- | union 2 PackageMp, choosing the first one in the ordering on the fly
pkgMpUnion :: PackageMp -> PackageMp -> PackageMp
pkgMpUnion
  = Map.unionWith (Map.unionWith cmb)
  where cmb p1s p2s = head $ groupBy eqp $ sortBy cmpp $ p1s ++ p2s
        -- cmb = (++)
        eqp  p1  p2  = pkginfoOrder p1 == pkginfoOrder p2
        cmpp p1  p2  = pkginfoOrder p1 `compare` pkginfoOrder p2

-- looking up just picks the first one
-- TBD: fix this: error/warning, etc
pkgMpLookup :: PkgKey -> PackageMp -> Maybe PackageInfo
pkgMpLookup (k1,k2) m1
  = fmap head $ mapLookup2 k1 k2 m1

-- | Get an element from a non empty PackageMp
pkgMpFindMin :: PackageMp -> PackageInfo
pkgMpFindMin m1
  = head ps
  where (_,m2) = Map.findMin m1
        (_,ps) = Map.findMin m2

pkgMpDifference :: PackageMp -> PackageMp -> PackageMp
pkgMpDifference mp mpDiff
  = foldr diff mp $ Map.toList mpDiff
  where diff (k1,mp2Diff) mp
          = case Map.lookup k1 mp of
              Just mp2 | Map.null m -> Map.delete k1 mp
                       | otherwise  -> Map.insert k1 m mp
                       where m = Map.difference mp2 mp2Diff
              _ -> mp

pkgMpUnions :: [PackageMp] -> PackageMp
pkgMpUnions = foldr pkgMpUnion Map.empty

pkgMpSingletonL :: PkgKey -> [PackageInfo] -> PackageMp
pkgMpSingletonL (k1,k2) i = Map.singleton k1 (Map.singleton k2 i)

pkgMpSingleton :: PkgKey -> PackageInfo -> PackageMp
pkgMpSingleton k i = pkgMpSingletonL k [i]

{-# LINE 109 "src/ehc/Base/PackageDatabase.chs" #-}
mod2pkgMpUnion :: Module2PackageMp -> Module2PackageMp -> Module2PackageMp
mod2pkgMpUnion = Map.unionWith (++)

mod2pkgMpUnions :: [Module2PackageMp] -> Module2PackageMp
mod2pkgMpUnions = foldr mod2pkgMpUnion Map.empty

{-# LINE 121 "src/ehc/Base/PackageDatabase.chs" #-}
pkgDbLookup:: PkgKey -> PackageDatabase -> Maybe PackageInfo
pkgDbLookup key db
  = pkgMpLookup key $ pkgDbPkgMp db

pkgMpSelectMpOnKey :: PkgKey -> PackageMp -> PackageMp
pkgMpSelectMpOnKey key@(pkgNm,mbVersion) mp
  = case mbVersion of
      Just pkgVersion -> case lkup of
                           Just m -> maybe emptyPackageMp (\i -> pkgMpSingletonL key i) $ Map.lookup mbVersion m
                           _      -> emptyPackageMp
      _               -> maybe emptyPackageMp (Map.singleton pkgNm) lkup
  where lkup = Map.lookup pkgNm mp

pkgDbSelectMpOnKey :: PkgKey -> PackageDatabase -> PackageMp
pkgDbSelectMpOnKey key@(pkgNm,mbVersion) db = pkgMpSelectMpOnKey key $ pkgDbPkgMp db
{-
  = case mbVersion of
      Just pkgVersion -> case lkup of
                           Just m -> maybe emptyPackageMp (\i -> pkgMpSingletonL key i) $ Map.lookup mbVersion m
                           _      -> emptyPackageMp
      _               -> maybe emptyPackageMp (Map.singleton pkgNm) lkup
  where lkup = Map.lookup pkgNm $ pkgDbPkgMp db
-}

{-# LINE 151 "src/ehc/Base/PackageDatabase.chs" #-}
-- | Write pkg config file into dir, using PkgOption
pkgWritePkgOptionAsCfg :: PkgOption -> FPath -> IO ()
pkgWritePkgOptionAsCfg pkgopt pkgfp
  = do mbCfgFP@(~(Just (cfgFP, pkgdir))) <- pkgCfgFPath True pkgfp
       if isJust mbCfgFP
         then writeFile (fpathToStr cfgFP) $ unlines $ map (\(k,v) -> k ++ ": " ++ v)
                [ ("exposed-modules", unwords $ pkgoptExposedModules pkgopt )
                , ("build-depends"  , unwords $ pkgoptBuildDepends   pkgopt )
                ]
         else return ()

{-# LINE 171 "src/ehc/Base/PackageDatabase.chs" #-}
-- parse content of a package config file, yielding updates to PackageInfo, ignoring unused fields
pkgCfgParse :: String -> [PackageInfo -> PackageInfo]
pkgCfgParse s
  = map (\(k,v) -> case map toLower k of
                     "exposed-modules" -> add (\ns i -> i {pkginfoExposedModules = Set.fromList ns}) parseModuleNames v
                     "build-depends"   -> add (\ns i -> i {pkginfoBuildDepends   = Set.fromList ns}) parsePkgKeys     v
                     "exposed"         -> add (\ex i -> i {pkginfoIsExposed      = ex             }) parseBool        v
                     _                 -> id
        ) $ Map.toList kvs
  where add upd parse v = maybe id upd $ parse v
        (kvs,_) = foldr p (Map.empty,"") $ lines s
        p s (kvs,saccum)
          = case elemIndex ':' s of
              Just colpos -> (Map.insert k (appendaccum v) kvs, "")
                          where (k,_:v) = splitAt colpos s
              _ -> (kvs,appendaccum s)
          where appendaccum s | null saccum = s
                              | otherwise   = s ++ " " ++ saccum

{-# LINE 192 "src/ehc/Base/PackageDatabase.chs" #-}
-- | For rhs of field 'exposed-modules'
pModuleNames :: P [HsName]
pModuleNames = pList (tokMkQName <$> (pQConidTk <|> pConidTk))

parseModuleNames :: String -> Maybe [HsName]
parseModuleNames = parseString (hsScanOpts defaultEHCOpts) pModuleNames

{-# LINE 201 "src/ehc/Base/PackageDatabase.chs" #-}
-- | For rhs of field 'exposed'
pBool :: P Bool
pBool = True <$ pKeyTk "True" <|> False <$ pKeyTk "False"

parseBool :: String -> Maybe Bool
parseBool = parseString (defaultScanOpts {scoKeywordsTxt = Set.fromList ["True","False"]}) pBool

{-# LINE 214 "src/ehc/Base/PackageDatabase.chs" #-}
-- read content of package dir + config file
pkgMpFromDirFile :: EHCOpts -> PkgKey -> Int -> FPath -> IO PackageMp
pkgMpFromDirFile opts pkgkey order pkgfp
  = do -- print pkgfp
       -- print mbKey
       -- isDir <- doesDirectoryExist pkgdir
       mbCfgFP@(~(Just (cfgFP, pkgdir))) <- pkgCfgFPath False pkgfp
       if isJust mbCfgFP -- isDir
         then do { let fpCfg = fpathToStr cfgFP
                       pkgInfo = PackageInfo (mkPkgFileLoc pkgkey pkgdir) order Set.empty Set.empty True
                 ; cfgExists <- doesFileExist fpCfg
                 ; pm <- if cfgExists
                   then do h <- openFile fpCfg ReadMode
                           cfg <- hGetContents h
                           let i = foldr ($) pkgInfo (pkgCfgParse cfg)
                           i `seq` hClose h
                           return $ pkgMpSingleton pkgkey i
                   else return $ pkgMpSingleton pkgkey pkgInfo
                 -- ; print pm
                 ; return pm
                 }
         else return Map.empty
  -- where pkgdir = fpathToStr pkgfp

-- read content of a dir containing package dirs
pkgMpFromDir :: EHCOpts -> Int -> FilePath -> IO PackageMp
pkgMpFromDir opts order fp
  = do { isDir <- doesDirectoryExist fp
       -- ; putStrLn ("dir-exists: " ++ show (fp,isDir))
       ; if isDir
         then do { pkgWithVersions <- getDirectoryContents fp
                 ; let pkgWithVersionsBases = catMaybes $
                                              map (\f -> do { k <- parsePkgKey f
                                                            ; return $ (k,fpathPrependDir fp $ fpathFromStr $
                                                                            mkInternalPkgFileBase k (Cfg.installVariant opts)
                                                                            (ehcOptTarget opts) (ehcOptTargetFlavor opts))
                                                            })
                                                  pkgWithVersions
                 -- putStrLn (show fp)
                 -- putStrLn (show pkgWithVersions)
                 -- putStrLn (show pkgWithVersionsBases)
                 ; mps <- mapM (\ (k,f) -> pkgMpFromDirFile opts k order f) pkgWithVersionsBases
                 -- ; putStrLn (show mps)
                 ; let mpsu = pkgMpUnions mps
                 ; return mpsu
                 }
         else return Map.empty
       }

-- read and combine contents of multiple package database directories
pkgDbFromDirs :: EHCOpts -> [FilePath] -> IO PackageDatabase
pkgDbFromDirs opts fps
  = do mps <- zipWithM (pkgMpFromDir opts) [1..] fps
       let mpsu = pkgMpUnions mps
       -- putStrLn ("unions: " ++ show mpsu)
       return (emptyPackageDatabase {pkgDbPkgMp = mpsu})

{-# LINE 277 "src/ehc/Base/PackageDatabase.chs" #-}
data SearchFilterState
  = SearchFilterState
      { sfstMp		:: PackageMp
      , sfstErr		:: [Err]
      }

-- | select from full package db, building a db according to the search filter, monadically
pkgDbSelectBySearchFilterM :: [PackageSearchFilter] -> PackageDatabase -> State SearchFilterState ()
pkgDbSelectBySearchFilterM searchFilters fullDb
  = all searchFilters
  where all searchFilters = forM_ searchFilters sel
        sel  PackageSearchFilter_HideAll         = modify $ \st -> st {sfstMp = emptyPackageMp}
        sel (PackageSearchFilter_HidePkg   keys) = forM_ keys (one (\_ -> return ()) (flip pkgMpDifference) (\_ m -> m))
        sel (PackageSearchFilter_ExposePkg keys) = forM_ keys (one onerec            (\_ m -> m           ) pkgMpUnion )
        one onerec cmbPresent cmbAbsent k = do
          -- get the package info (inside a map) from the full db
          let s = pkgDbSelectMpOnKey k fullDb
          if Map.null s
            -- if not in full db, error
            then modify $ \st -> st {sfstErr = sfstErr st ++ [mkErr_NamesNotIntrod emptyRange "package" [mkHNm k]]}
            else do
              -- get the package map under construction
              mp <- gets sfstMp
              let inMp = pkgMpSelectMpOnKey k mp
              if Map.null inMp
                then do
                  -- if not yet encountered, add it, and recurse over the dependends
                  modify $ \st -> st {sfstMp = cmbAbsent s mp}
                  onerec s
                else
                  modify $ \st -> st {sfstMp = cmbPresent s mp}
        onerec s = all [PackageSearchFilter_ExposePkg $ Set.toList $ pkginfoBuildDepends $ pkgMpFindMin s]

-- | select from full package db, building a db according to the search filter
pkgDbSelectBySearchFilter :: [PackageSearchFilter] -> PackageDatabase -> (PackageDatabase, [Err])
pkgDbSelectBySearchFilter searchFilters fullDb
  = (emptyPackageDatabase {pkgDbPkgMp = sfstMp st}, sfstErr st)
  where st = execState (pkgDbSelectBySearchFilterM searchFilters fullDb) (SearchFilterState emptyPackageMp [])

{-# LINE 337 "src/ehc/Base/PackageDatabase.chs" #-}
type PkgModulePartition
  = ( PkgKey				-- package
    , String				-- unused: dir
    , [HsName]				-- unused: mod names
    )

{-# LINE 351 "src/ehc/Base/PackageDatabase.chs" #-}
-- | Obtain the locations to be included in general and per package (together with modules from pkg)
pkgPartInclDirs :: EHCOpts -> [PkgModulePartition] -> ([FilePath], Map.Map PkgKey (FilePath,[HsName]))
pkgPartInclDirs opts pkgKeyDirL
  = ( [ mki kind dir | FileLoc kind dir <- ehcOptImportFileLocPath opts, not (null dir) ]
    , Map.fromList $ catMaybes [ mkp p | p <- pkgKeyDirL ]
    )
  where mki (FileLocKind_Dir    ) d = d
        mki (FileLocKind_Pkg _ _) d = Cfg.mkPkgIncludeDir $ filePathMkPrefix d
        mki  FileLocKind_PkgDb    d = Cfg.mkPkgIncludeDir $ filePathMkPrefix d
        mkp (k,_,ms) = fmap (\d -> (k, (Cfg.mkPkgIncludeDir $ filePathMkPrefix $ filelocDir $ pkginfoLoc d, ms))) $ pkgDbLookup k $ ehcOptPkgDb opts

{-# LINE 371 "src/ehc/Base/PackageDatabase.chs" #-}
pkgExposedPackages :: PackageDatabase -> [PkgModulePartition]
pkgExposedPackages db
  = [ ((k1,k2),"",[])
    | (k1,mp1) <- Map.toList $ pkgDbPkgMp db
    , (k2,is ) <- Map.toList mp1
    , i        <- is						-- TBD: disambiguation
    , pkginfoIsExposed i
    ]

{-# LINE 386 "src/ehc/Base/PackageDatabase.chs" #-}
pkgDbFreeze :: PackageDatabase -> PackageDatabase
pkgDbFreeze db
  = db {pkgDbMod2PkgMp = m2p}
  where m2p
          = mod2pkgMpUnions
              [ mod2pkgMpUnions
                  [ Map.singleton m [(k1,k2)]
                  | m <- Set.toList $ pkginfoExposedModules i
                  ]
              | (k1,mp1) <- Map.toList $ pkgDbPkgMp db
              , (k2,is)  <- Map.toList mp1
              , i        <- is
              ]

{-# LINE 406 "src/ehc/Base/PackageDatabase.chs" #-}
-- | For a module, find the package to use and the location of the root dir of that package.
pkgDbSearch :: PackageDatabase -> HsName -> Maybe (PkgKey,FilePath,[Err])
pkgDbSearch db modNm
  = do pkgs <- mbPkgs
       dirOf $ disambig pkgs
  where mbPkgs   = Map.lookup modNm $ pkgDbMod2PkgMp db
        disambig pks
                 = case sortBy cmp pks of
                     [k]               -> (k,[])          -- no ambiguity
                     (k@(_,Nothing):_) -> (k,[])          -- versionless overrides others
                     ks@(k:_)          -> (k,[rngLift emptyRange Err_AmbiguousNameRef "module" "package" modNm (map (mkHNm . strOf) ks)])
                 where cmp (_,Nothing) (_,Nothing) = EQ                 -- versionless goes first
                       cmp (_,Nothing) (_,_      ) = LT
                       cmp (_,k21    ) (_,k22    ) = compare k22 k21    -- then highest version
        pkgOf  k    = pkgMpLookup k $ pkgDbPkgMp db
        strOf  k    = showPkgKey k ++ ": " ++ maybe "" (\i -> show (pkginfoLoc i) ++ ":" ++ show (pkginfoOrder i)) (pkgOf k)
        dirOf (k,e) = fmap (\i -> (k,filelocDir $ pkginfoLoc i,e)) $ pkgOf k

{-# LINE 426 "src/ehc/Base/PackageDatabase.chs" #-}
-- look up a file location, defaults to plain file search except for a package db which is then queried
fileLocSearch :: EHCOpts -> FileLoc -> HsName -> FPath -> [(FileLoc,FPath,[Err])]
fileLocSearch opts loc modNm fp
  = case {- tr "fileLocSearch1" (show modNm ++ ": " ++ show fp ++ " " ++ show loc) $ -} filelocKind loc of
      FileLocKind_PkgDb
        -> maybe [] srch $ pkgDbSearch (ehcOptPkgDb opts) modNm
        where srch (k,d,e) = [ (mkPkgFileLoc k d',fp',e) | (d',fp') <- searchFPathFromLoc d fp ]
      _ -> [ (loc,fp',[]) | (_,fp') <- searchFPathFromLoc (filelocDir loc) fp ]