-- |
-- Module      :  Distribution.Package.Debian.Bundled
-- Copyright   :  David Fox 2008
--
-- Maintainer  :  David Fox <dsf@seereason.com>
-- Stability   :  alpha
-- Portability :  portable
--
-- Determine whether a specific version of a Haskell package is
-- bundled with into this particular version of the given compiler.

-- This software may be used and distributed according to the terms of
-- the GNU General Public License, incorporated herein by reference.

module Distribution.Package.Debian.Bundled
    (
      Bundled 
    , bundledWith
    , isBundled
    , isLibrary
    -- , builtIns
    -- , ghc6BuiltIns
    , PackageType(..)
    , debianName
    , versionSplits
    , ghcBuiltIns
    ) where

import qualified Data.ByteString.Char8 as B
import Data.Char (toLower)
import Data.Function (on)
import Data.List (find, isPrefixOf, sortBy)
import qualified Data.Map as Map
import Data.Maybe (maybeToList, fromJust)
import Data.Version (Version(..))
import Debian.Control(Control'(Control), fieldValue, parseControlFromFile)
import Debian.Relation.ByteString()
import Debian.Relation(Relation(Rel),parseRelations)
import Distribution.InstalledPackageInfo(libraryDirs, sourcePackageId)
import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), PackageDB(GlobalPackageDB), compilerFlavor)
import Distribution.Simple.Configure (getInstalledPackages)
-- import Distribution.Simple.GHC  (getInstalledPackages)
import Distribution.Simple.PackageIndex (PackageIndex, SearchResult(None, Unambiguous), allPackages, searchByName)
import Distribution.Simple.Program (configureAllKnownPrograms, defaultProgramConfiguration)
import Distribution.Package (PackageIdentifier(..), PackageName(..), Dependency(..))
import Distribution.Verbosity(normal)
import Distribution.Version (withinRange, VersionRange(..))
--import System.Unix.Chroot (fchroot)
--import System.Unix.Process (lazyProcess, collectStdout)
--import Data.ByteString.Lazy.Char8 (empty, unpack)
import Text.ParserCombinators.Parsec(ParseError)
import Text.Regex.TDFA ((=~))

-- | List the packages bundled with this version of the given
-- compiler.  If the answer is not known, return the empty list.
bundledWith :: [(CompilerFlavor, Version, [PackageIdentifier])] -> Compiler -> Maybe [PackageIdentifier]
bundledWith builtIns c =
    let cv = (compilerFlavor c, (\ (CompilerId _ v) -> v) $ compilerId c)
    in thd `fmap` find (\(n,v,_) -> (n,v) == cv) builtIns
  where thd (_,_,x) = x

-- | Determine whether a specific version of a Haskell package is
-- bundled with into this particular version of the given compiler.
isBundled :: [(CompilerFlavor, Version, [PackageIdentifier])] -> Compiler -> Dependency -> Bool
isBundled builtIns c (Dependency pkg version) =
    let cv = (compilerFlavor c, (\ (CompilerId _ v) -> v) (compilerId c))
    in
      case find (\(n, k, _) -> (n,k) == cv) builtIns of
        Nothing -> False
        (Just (_, _, cb)) ->
          any checkVersion $ pkgVersion `fmap` filter ((== pkg) . pkgName) cb
  where checkVersion = flip withinRange version

type Bundled = (CompilerFlavor, Version, [PackageIdentifier])

-- |Return a list of built in packages for the compiler in an environment.
-- ghcBuiltIns :: FilePath -> IO [PackageIdentifier]
-- ghcBuiltIns root =
--     fchroot root (lazyProcess "ghc-pkg" ["list", "--simple-output"] Nothing Nothing empty) >>=
--     return . map parsePackageIdentifier . words . unpack . fst . collectStdout
--     where
--       parsePackageIdentifier s =
--           let (v', n') = break (== '-') (reverse s)
--               (v, n) = (reverse (tail n'), reverse v') in
--           PackageIdentifier (PackageName n) (Version (map read (filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) v))) [])

ghcBuiltIns :: Compiler -> Bundled
ghcBuiltIns (Compiler {compilerId = CompilerId GHC compilerVersion}) =
    case Map.lookup compilerVersion
             (Map.fromList [ (Version [7,2,1] [], (GHC, Version [7,2,1] [], ghc721BuiltIns))
                           , (Version [7,0,4] [], (GHC, Version [7,0,4] [], ghc701BuiltIns))
                           , (Version [7,0,3] [], (GHC, Version [7,0,3] [], ghc701BuiltIns))
                           , (Version [7,0,1] [], (GHC, Version [7,0,1] [], ghc701BuiltIns))
                           , (Version [6,8,3] [], (GHC, Version [6,8,3] [], ghc683BuiltIns))
                           , (Version [6,8,2] [], (GHC, Version [6,8,2] [], ghc682BuiltIns))
                           , (Version [6,8,1] [], (GHC, Version [6,8,1] [], ghc681BuiltIns))
                           , (Version [6,6,1] [], (GHC, Version [6,6,1] [], ghc661BuiltIns))
                           , (Version [6,6] [], (GHC, Version [6,6] [], ghc66BuiltIns)) ]) of
      Nothing -> error $ "cabal-debian: No bundled package list for ghc " ++ show compilerVersion
      Just x -> x

_builtIns :: Compiler -> IO [Bundled]
_builtIns compiler = 
    do ghc6 <- fmap maybeToList $ ghc6BuiltIns compiler
       return $ ghc6 ++ [ (GHC, Version [7,2,1] [], ghc721BuiltIns)
                        , (GHC, Version [7,0,3] [], ghc701BuiltIns)
                        , (GHC, Version [7,0,1] [], ghc701BuiltIns)
                        , (GHC, Version [6,8,3] [], ghc683BuiltIns)
                        , (GHC, Version [6,8,2] [], ghc682BuiltIns)
                        , (GHC, Version [6,8,1] [], ghc681BuiltIns)
                        , (GHC, Version [6,6,1] [], ghc661BuiltIns)
                        , (GHC, Version [6,6] [], ghc66BuiltIns)
                        ]

_ghc6BuiltIns :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier]))
_ghc6BuiltIns compiler@(Compiler {compilerId = CompilerId GHC compilerVersion}) =
#ifdef CABAL19
    do installedPackages <- _getInstalledPackageIndex compiler
       ghc6Files <- fmap lines $ readFile "/var/lib/dpkg/info/ghc.list"
       let ghcProvides = filter (\package -> any (\dir -> elem dir ghc6Files) (libraryDirs package)) (allPackages installedPackages)
       return (Just (GHC, compilerVersion, map sourcePackageId ghcProvides))
#else
    do mInstalledPackages <- getInstalledPackageIndex compiler
       case mInstalledPackages of
         Nothing -> error "Could not find the installed package database."
         (Just installedPackages) ->
             do ghc6Files <- fmap lines $ readFile "/var/lib/dpkg/info/ghc.list"
                let ghcProvides = filter (\package -> any (\dir -> elem dir ghc6Files) (libraryDirs package)) (allPackages installedPackages)
                return (Just (GHC, compilerVersion, map sourcePackageId ghcProvides))
#endif
ghc6BuiltIns _ = return Nothing

_ghc6BuiltIns' :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier]))
_ghc6BuiltIns' compiler@(Compiler {compilerId = CompilerId GHC compilerVersion}) =
    do eDebs <- _ghc6Provides
       case eDebs of
         Left e -> error e
         Right debNames ->
#ifdef CABAL19
             do installedPackages <- _getInstalledPackageIndex compiler
                let packages = concatMap (\n -> fromRight $ _installedVersions (fromRight $ _extractBaseName n) installedPackages) debNames
                return $ Just (GHC, compilerVersion, packages)
#else
             do mInstalledPackages <- getInstalledPackageIndex compiler
                case mInstalledPackages of
                  Nothing -> error "Could not find the installed package database."
                  (Just installedPackages) ->
                      let packages = concatMap (\n -> fromRight $ installedVersions (fromRight $ _extractBaseName n) installedPackages) debNames
                      in
                        return $ Just (GHC, compilerVersion, packages)
#endif
    where
      fromRight (Right r) = r
      fromRight (Left e) = error e
_ghc6BuiltIns' (Compiler {}) = return Nothing

_ghc6Provides :: IO (Either String [String])
_ghc6Provides = 
    do eC <- parseControlFromFile "/var/lib/dpkg/status" :: IO (Either ParseError (Control' B.ByteString))
       case eC of
         Left e  -> return $ Left (show e)
         Right (Control c) ->
             case find (\p -> fieldValue "Package" p == Just (B.pack "ghc")) c of
               Nothing -> return $ Left "You do not seem to have ghc installed."
               (Just p) ->
                   case fieldValue "Provides" p of
                     Nothing -> return $ Left "Your ghc package does not seem to Provide anything."
                     (Just p) -> 
                         case parseRelations p of
                           (Left e) -> return (Left (show e))
                           (Right relations) ->
                               return $ Right $ filter (isPrefixOf "libghc-") $ map (\ (Rel pkgName _ _) -> pkgName) (concat relations)


_extractBaseName :: String -> Either String String
_extractBaseName name =
    let (_,_,_,subs) = (name =~ "^libghc-(.*)-.*$") :: (String, String, String, [String])
    in case subs of
         [base] -> Right base
         _ -> Left ("When attempt to extract the base name of " ++ name ++ " I found the following matches: " ++ show subs)
                 
--getInstalledPackageIndex :: Compiler -> IO (Maybe PackageIndex)
_getInstalledPackageIndex compiler =
    do pc  <- configureAllKnownPrograms normal  defaultProgramConfiguration
       getInstalledPackages normal compiler [GlobalPackageDB] pc

_installedVersions :: String -> PackageIndex -> Either String [PackageIdentifier]
_installedVersions name packageIndex = 
    case searchByName packageIndex name of
      None -> Left $ "The package " ++ name ++ " does not seem to be installed."
      Unambiguous pkgs -> 
          case sortBy (compare `on` (pkgVersion . sourcePackageId)) pkgs of
            [] -> Left $ "Odd. searchByName returned an empty Unambiguous match for " ++ name
            ps -> Right (map sourcePackageId ps)
                                   
v :: String -> [Int] -> PackageIdentifier
v n x = PackageIdentifier (PackageName n) (Version x [])

ghc721BuiltIns :: [PackageIdentifier]
ghc721BuiltIns = [
    v "Cabal" [1,12,0],
    v "array" [0,3,0,3],
    v "base" [4,4,0,0],
    v "bin-package-db" [0,0,0,0],
    v "binary" [0,5,0,2],
    v "bytestring" [0,9,2,0],
    v "containers" [0,4,1,0],
    v "directory" [1,1,0,1],
    v "extensible-exceptions" [0,1,1,3],
    v "filepath" [1,2,0,1],
    v "ghc" [7,2,1],
    -- ghc-binary renamed to binary
    v "ghc-prim" [0,2,0,0],
    v "haskell2010" [1,1,0,0],
    v "haskell98" [2,0,0,0],
    v "hoopl" [3,8,7,1], -- new
    v "hpc" [0,5,1,0],
    v "integer-gmp" [0,3,0,0],
    v "old-locale" [1,0,0,3],
    v "old-time" [1,0,0,7],
    v "pretty" [1,1,0,0],
    v "process" [1,1,0,0], 
    -- random removed
    v "rts" [1,0],
    v "template-haskell" [2,6,0,0],
    v "time" [1,2,0,5],
    v "unix" [2,5,0,0] ]

ghc701BuiltIns :: [PackageIdentifier]
ghc701BuiltIns = [
    v "Cabal" [1,10,0,0],
    v "array" [0,3,0,2],
    v "base" [4,3,0,0],
    v "bin-package-db" [0,0,0,0],
    v "bytestring" [0,9,1,8],
    v "containers" [0,4,0,0],
    v "directory" [1,1,0,0],
    v "extensible-exceptions" [0,1,1,2],
    v "filepath" [1,2,0,0],
    v "ghc" [7,0,1],
    v "ghc-binary" [0,5,0,2],
    v "ghc-prim" [0,2,0,0],
    v "haskell2010" [1,0,0,0],
    v "haskell98" [1,1,0,0],
    v "hpc" [0,5,0,6],
    v "integer-gmp" [0,2,0,2],
    v "old-locale" [1,0,0,2],
    v "old-time" [1,0,0,6],
    v "pretty" [1,0,1,2],
    v "process" [1,0,1,4],
    v "random" [1,0,0,3],
    v "rts" [1,0],
    v "template-haskell" [2,5,0,0],
    v "time" [1,2,0,3],
    v "unix" [2,4,1,0]
  ]

ghc683BuiltIns :: [PackageIdentifier]
ghc683BuiltIns = ghc682BuiltIns

ghc682BuiltIns :: [PackageIdentifier]
ghc682BuiltIns = [
    v "Cabal" [1,2,3,0],
    v "array" [0,1,0,0],
    v "base" [3,0,1,0],
    v "bytestring" [0,9,0,1],
    v "containers" [0,1,0,1],
    v "directory" [1,0,0,0],
    v "filepath" [1,1,0,0],
    v "ghc" [6,8,2,0],
    v "haskell98" [1,0,1,0],
    v "hpc" [0,5,0,0],
    v "old-locale" [1,0,0,0],
    v "old-time" [1,0,0,0],
    v "packedstring" [0,1,0,0],
    v "pretty" [1,0,0,0],
    v "process" [1,0,0,0],
    v "random" [1,0,0,0],
    v "readline" [1,0,1,0],
    v "template-haskell" [2,2,0,0],
    v "unix" [2,3,0,0]
    ]

ghc681BuiltIns :: [PackageIdentifier]
ghc681BuiltIns = [
    v "base" [3,0,0,0],
    v "Cabal" [1,2,2,0],
    v "GLUT" [2,1,1,1],
    v "HGL" [3,2,0,0],
    v "HUnit" [1,2,0,0],
    v "OpenAL" [1,3,1,1],
    v "OpenGL" [2,2,1,1],
    v "QuickCheck" [1,1,0,0],
    v "X11" [1,2,3,1],
    v "array" [0,1,0,0],
    v "bytestring" [0,9,0,1],
    v "cgi" [3001,1,5,1],
    v "containers" [0,1,0,0],
    v "directory" [1,0,0,0],
    v "fgl" [5,4,1,1],
    v "filepatch" [1,1,0,0],
    v "ghc" [6,8,1,0],
    v "haskell-src" [1,0,1,1],
    v "haskell98" [1,0,1,0],
    v "hpc" [0,5,0,0],
    v "html" [1,0,1,1],
    v "mtl" [1,1,0,0],
    v "network" [2,1,0,0],
    v "old-locale" [1,0,0,0],
    v "old-time" [1,0,0,0],
    v "packedstring" [0,1,0,0],
    v "parallel" [1,0,0,0],
    v "parsec" [2,1,0,0],
    v "pretty" [1,0,0,0],
    v "process" [1,0,0,0],
    v "random" [1,0,0,0],
    v "readline" [1,0,1,0],
    v "regex-base" [0,72,0,1],
    v "regex-compat" [0,71,0,1],
    v "regex-posix" [0,72,0,1],
    v "stm" [2,1,1,0],
    v "template-haskell" [2,2,0,0],
    v "time" [1,1,2,0],
    v "unix" [2,2,0,0],
    v "xhtml" [3000,0,2,1]
    ]

ghc661BuiltIns :: [PackageIdentifier]
ghc661BuiltIns = [
    v "base" [2,1,1],
    v "Cabal" [1,1,6,2],
    v "cgi" [3001,1,1],
    v "fgl" [5,4,1],
    v "filepath" [1,0],
    v "ghc" [6,6,1],
    v "GLUT" [2,1,1],
    v "haskell98" [1,0],
    v "haskell-src" [1,0,1],
    v "HGL" [3,1,1],
    v "html" [1,0,1],
    v "HUnit" [1,1,1],
    v "mtl" [1,0,1],
    v "network" [2,0,1],
    v "OpenAL" [1,3,1],
    v "OpenGL" [2,2,1],
    v "parsec" [2,0],
    v "QuickCheck" [1,0,1],
    v "readline" [1,0],
    v "regex-base" [0,72],
    v "regex-compat" [0,71],
    v "regex-posix" [0,71],
    v "rts" [1,0],
    v "stm" [2,0],
    v "template-haskell" [2,1],
    v "time" [1,1,1],
    v "unix" [2,1],
    v "X11" [1,2,1],
    v "xhtml" [3000,0,2]
    ]

ghc66BuiltIns :: [PackageIdentifier]
ghc66BuiltIns = [
    v "base" [2,0],
    v "Cabal" [1,1,6],
    v "cgi" [2006,9,6],
    v "fgl" [5,2],
    v "ghc" [6,6],
    v "GLUT" [2,0],
    v "haskell98" [1,0],
    v "haskell-src" [1,0],
    v "HGL" [3,1],
    v "html" [1,0],
    v "HTTP" [2006,7,7],
    v "HUnit" [1,1],
    v "mtl" [1,0],
    v "network" [2,0],
    v "OpenAL" [1,3],
    v "OpenGL" [2,1],
    v "parsec" [2,0],
    v "QuickCheck" [1,0],
    v "readline" [1,0],
    v "regex-base" [0,71],
    v "regex-compat" [0,71],
    v "regex-posix" [0,71],
    v "rts" [1,0],
    v "stm" [2,0],
    v "template-haskell" [2,0],
    v "time" [1,0],
    v "unix" [1,0],
    v "X11" [1,1],
    v "xhtml" [2006,9,13]
    ]

-- |Some dependencies are libraries, some are executables.
isLibrary :: Compiler -> Dependency -> Bool
isLibrary _ (Dependency (PackageName "happy") _ ) = False
isLibrary _ _ = True

data PackageType = Source | Development | Profiling | Documentation | Utilities | Extra deriving (Eq, Show)

{-
debianName :: PackageType -> PackageName -> Maybe Version -> String
debianName typ (PackageName name) version =
    prefix typ ++ foldr f def versionSplits ++ suffix typ
    where
      f (PackageName n, v, ltName, geName) debName =
          if n == name
          -- For unversioned dependencies (when version is Nothing),
          -- use the name corresponding to the newest version number.
          then if maybe True (>= v) version
               then geName
               else ltName
          else debName
      -- No splits apply, make the name safe for Debian
      def = map fixChar name
-}

debianName :: PackageType -> PackageName -> VersionRange -> String
debianName typ (PackageName name) version =
    prefix typ ++ foldr f def versionSplits ++ suffix typ
    where
      f (PackageName n, v, ltName, geName) debName =
          if n == name
          -- For unversioned dependencies (when version is Nothing),
          -- use the name corresponding to the newest version number.
          then case version of
                 AnyVersion -> geName
                 ThisVersion v' | v' >= v -> geName
                 ThisVersion _ -> ltName
                 LaterVersion v' -> geName
                 EarlierVersion v' | v' >= v -> ltName
                 EarlierVersion v' -> geName
                 _ -> error $ "debianName - unexpected version range: " ++ show version
          else debName
      -- make the name safe for Debian
      def = case name of
              -- The debian package haskell-src-exts should have been
              -- called haskell-haskell-src-exts.  Consequently, the
              -- binary packages are missing a "haskell-" prefix, so we
              -- need to generated dependencies to match.
              "haskell-src-exts" -> "src-exts"
              _ -> map fixChar name

versionSplits = [(PackageName "parsec", Version [3] [], "parsec2", "parsec3"),
                 (PackageName "QuickCheck", Version [2] [], "quickcheck1", "quickcheck2")]

suffix Source = ""
suffix Documentation = "-doc"
suffix Development = "-dev"
suffix Profiling = "-prof"
suffix Utilities = "-utils"
suffix Extra = ""

prefix Source = "haskell-"
prefix Documentation = "libghc-"
prefix Development = "libghc-"
prefix Profiling = "libghc-"
prefix Utilities = "haskell-"
prefix Extra = ""

fixChar :: Char -> Char
fixChar '_' = '-'
fixChar c = toLower c