content: module Actions ( cabalUpdate
                 , installCabalConfig
                 , installCabalWrapper
                 , installActivateScript
                 , copyBaseSystem
                 , initGhcDb
                 , installGhc
                 , createDirStructure
                 ) where
  
  import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory, removeDirectoryRecursive)
  import System.FilePath ((</>))
  import Distribution.Version (Version (..))
  import Distribution.Package (PackageName(..))
  import Safe (lastMay)
  import Data.List (intercalate)
  
  import MyMonad
  import Types
  import Paths
  import PackageManagement
  import Process
  import Util.Template (substs)
  import Util.IO (makeExecutable, createTemporaryDirectory)
  import Skeletons
  
  -- update cabal package info inside Virtual Haskell Environmentn
  cabalUpdate :: MyMonad ()
  cabalUpdate = do
    env         <- getVirtualEnvironment
    cabalConfig <- cabalConfigLocation
    info "Updating cabal package database inside Virtual Haskell Environment."
    _ <- indentMessages $ runProcess (Just env) "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing
    return ()
  
  -- install cabal wrapper (in bin/ directory) inside virtual environment dir structure
  installCabalWrapper :: MyMonad ()
  installCabalWrapper = do
    cabalConfig      <- cabalConfigLocation
    dirStructure     <- vheDirStructure
    let cabalWrapper = virthualEnvBinDir dirStructure </> "cabal"
    info $ concat [ "Installing cabal wrapper using "
                  , cabalConfig
                  , " at "
                  , cabalWrapper
                  ]
    let cabalWrapperContents = substs [("<CABAL_CONFIG>", cabalConfig)] cabalWrapperSkel
    indentMessages $ do
      trace "cabal wrapper contents:"
      indentMessages $ mapM_ trace $ lines cabalWrapperContents
    liftIO $ writeFile cabalWrapper cabalWrapperContents
    liftIO $ makeExecutable cabalWrapper
  
  installActivateScriptSupportFiles :: MyMonad ()
  installActivateScriptSupportFiles = do
    debug "installing supporting files"
    dirStructure <- vheDirStructure
    ghc <- asks ghcSource
    indentMessages $ do
      let pathVarPrependixLocation = virthualEnvDir dirStructure </> "path_var_prependix"
          pathVarElems =
              case ghc of
                System    -> [virthualEnvBinDir dirStructure, cabalBinDir dirStructure]
                Tarball _ -> [ virthualEnvBinDir dirStructure
                            , cabalBinDir dirStructure
                            , ghcBinDir dirStructure
                            ]
          pathVarPrependix = intercalate ":" pathVarElems
      debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation
      indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix
      liftIO $ writeFile pathVarPrependixLocation pathVarPrependix
      ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation
      let ghcPackagePathVarLocation = virthualEnvDir dirStructure </> "ghc_package_path_var"
          ghcPackagePathVar         = ghcPkgDbPath
      debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation
      indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar
      liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar
  
  -- install activate script (in bin/ directory) inside virtual environment dir structure
  installActivateScript :: MyMonad ()
  installActivateScript = do
    info "Installing activate script"
    virthualEnvName <- asks vheName
    dirStructure    <- vheDirStructure
    ghcPkgDbPath    <- indentMessages ghcPkgDbPathLocation
    let activateScript = virthualEnvBinDir dirStructure </> "activate"
    indentMessages $ debug $ "using location: " ++ activateScript
    let activateScriptContents = substs [ ("<VIRTHUALENV_NAME>", virthualEnvName)
                                        , ("<VIRTHUALENV_DIR>", virthualEnvDir dirStructure)
                                        , ("<VIRTHUALENV>", virthualEnv dirStructure)
                                        , ("<GHC_PACKAGE_PATH>", ghcPkgDbPath)
                                        , ("<VIRTHUALENV_BIN_DIR>", virthualEnvBinDir dirStructure)
                                        , ("<CABAL_BIN_DIR>", cabalBinDir dirStructure)
                                        , ("<GHC_BIN_DIR>", ghcBinDir dirStructure)
                                        ] activateSkel
    indentMessages $ do
      trace "activate script contents:"
      indentMessages $ mapM_ trace $ lines activateScriptContents
    liftIO $ writeFile activateScript activateScriptContents
    indentMessages installActivateScriptSupportFiles
  
  -- install cabal's config file (in cabal/ directory) inside virtual environment dir structure
  installCabalConfig :: MyMonad ()
  installCabalConfig = do
    cabalConfig     <- cabalConfigLocation
    dirStructure    <- vheDirStructure
    info $ "Installing cabal config at " ++ cabalConfig
    let cabalConfigContents = substs [ ("<GHC_PACKAGE_PATH>", ghcPackagePath dirStructure)
                                     , ("<CABAL_DIR>", cabalDir dirStructure)
                                     ] cabalConfigSkel
    indentMessages $ do
      trace "cabal config contents:"
      indentMessages $ mapM_ trace $ lines cabalConfigContents
    liftIO $ writeFile cabalConfig cabalConfigContents
  
  createDirStructure :: MyMonad ()
  createDirStructure = do
    dirStructure <- vheDirStructure
    info "Creating Virtual Haskell directory structure"
    indentMessages $ do
      debug $ "virthualenv directory: " ++ virthualEnvDir dirStructure
      liftIO $ createDirectory $ virthualEnvDir dirStructure
      debug $ "cabal directory: " ++ cabalDir dirStructure
      liftIO $ createDirectory $ cabalDir dirStructure
      debug $ "virthualenv bin directory: " ++ virthualEnvBinDir dirStructure
      liftIO $ createDirectory $ virthualEnvBinDir dirStructure
  
  -- initialize private GHC package database inside virtual environment
  initGhcDb :: MyMonad ()
  initGhcDb = do
    dirStructure <- vheDirStructure
    info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure
    out <- indentMessages $ outsideGhcPkg ["--version"]
    case lastMay $ words out of
      Nothing            -> throwError $ MyException $ "Couldn't extract ghc-pkg version number from: " ++ out
      Just versionString -> do
        indentMessages $ trace $ "Found version string: " ++ versionString
        version <- parseVersion versionString
        let ghc_6_12_1_version = Version [6,12,1] []
        if version < ghc_6_12_1_version then do
          indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'"
          liftIO $ writeFile (ghcPackagePath dirStructure) "[]"
         else do
          _ <- indentMessages $ outsideGhcPkg ["init", ghcPackagePath dirStructure]
          return ()
  
  -- copy optional packages and don't fail completely if this copying fails
  -- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010)
  transplantOptionalPackage :: String -> MyMonad ()
  transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler
    where handler e = do
            warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: "
            indentMessages $ warning $ getExceptionMessage e
  
  -- copy base system
  -- base - needed for ghci and everything else
  -- Cabal - needed to install non-trivial cabal packages with cabal-install
  -- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy)
  -- haskell2010 - maybe it's similar to haskell98?
  -- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way
  -- also include dependant packages of all the above
  -- when using GHC from tarball, just reuse its package database
  -- cannot do the same when using system's GHC, because there might be additional packages installed
  -- then it wouldn't be possible to work on them insie virtual environment
  copyBaseSystem :: MyMonad ()
  copyBaseSystem = do
    info "Copying necessary packages from original GHC package database"
    indentMessages $ do
      ghc <- asks ghcSource
      case ghc of
        System -> do
          transplantPackage $ PackageName "base"
          transplantPackage $ PackageName "Cabal"
          mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"]
        Tarball _ ->
          debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database"
  
  installGhc :: MyMonad ()
  installGhc = do
    info "Installing GHC"
    ghc <- asks ghcSource
    case ghc of
      System              -> indentMessages $ debug "Using system version of GHC - nothing to install."
      Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath
  
  installExternalGhc :: FilePath -> MyMonad ()
  installExternalGhc tarballPath = do
    info $ "Installing GHC from " ++ tarballPath
    indentMessages $ do
      dirStructure <- vheDirStructure
      tmpGhcDir <- liftIO $ createTemporaryDirectory (virthualEnv dirStructure) "ghc"
      debug $ "Unpacking GHC tarball to " ++ tmpGhcDir
      _ <- indentMessages $ runProcess Nothing "tar" ["xf", tarballPath, "-C", tmpGhcDir, "--strip-components", "1"] Nothing
      let configureScript = tmpGhcDir </> "configure"
      debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure
      cwd <- liftIO getCurrentDirectory
      liftIO $ setCurrentDirectory tmpGhcDir
      make <- asks makeCmd
      let configureAndInstall = do
            _ <- indentMessages $ runProcess Nothing configureScript ["--prefix=" ++ ghcDir dirStructure] Nothing
            debug $ "Installing GHC with " ++ make ++ " install"
            _ <- indentMessages $ runProcess Nothing make ["install"] Nothing
            return ()
      configureAndInstall `finally` liftIO (setCurrentDirectory cwd)
      liftIO $ removeDirectoryRecursive tmpGhcDir
      return ()
  