{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
module Stack.Init
    ( initProject
    , InitOpts (..)
    , SnapPref (..)
    , Method (..)
    ) where

import           Control.Exception               (assert)
import           Control.Exception.Enclosed      (catchAny, handleIO)
import           Control.Monad                   (liftM, when)
import           Control.Monad.Catch             (MonadMask, throwM)
import           Control.Monad.IO.Class
import           Control.Monad.Logger
import           Control.Monad.Reader            (MonadReader)
import           Control.Monad.Trans.Control     (MonadBaseControl)
import qualified Data.ByteString.Builder         as B
import qualified Data.ByteString.Lazy            as L
import qualified Data.HashMap.Strict             as HM
import qualified Data.IntMap                     as IntMap
import qualified Data.Foldable                   as F
import           Data.List                       (sortBy)
import           Data.List.Extra                 (nubOrd)
import           Data.Map                        (Map)
import qualified Data.Map                        as Map
import           Data.Maybe                      (mapMaybe)
import           Data.Monoid
import qualified Data.Text                       as T
import qualified Data.Yaml                       as Yaml
import qualified Distribution.PackageDescription as C
import           Network.HTTP.Client.Conduit     (HasHttpManager)
import           Path
import           Path.IO
import           Stack.BuildPlan
import           Stack.Constants
import           Stack.Solver
import           Stack.Types
import           Stack.Types.Internal            ( HasTerminal, HasReExec
                                                 , HasLogLevel)
import           System.Directory                ( getDirectoryContents
                                                 , makeRelativeToCurrentDirectory)
import           Stack.Config                    ( getSnapshots
                                                 , makeConcreteResolver)

-- | Generate stack.yaml
initProject
    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m
       , MonadReader env m, HasConfig env , HasGHCVariant env
       , HasHttpManager env , HasLogLevel env , HasReExec env
       , HasTerminal env)
    => Path Abs Dir
    -> InitOpts
    -> m ()
initProject currDir initOpts = do
    let dest = currDir </> stackDotYaml
        dest' = toFilePath dest

    reldest <- liftIO $ makeRelativeToCurrentDirectory dest'

    exists <- fileExists dest
    when (not (forceOverwrite initOpts) && exists) $ do
        error ("Stack configuration file " <> reldest <>
               " exists, use 'stack solver' to fix the existing config file or \
               \'--force' to overwrite it.")

    let noPkgMsg =  "In order to init, you should have an existing .cabal \
                    \file. Please try \"stack new\" instead."

        dupPkgFooter = "You have the following options:\n"
            <> "- Use '--ignore-subdirs' command line switch to ignore "
            <> "packages in subdirectories. You can init subdirectories as "
            <> "independent projects.\n"
            <> "- Put selected packages in the stack config file "
            <> "and then use 'stack solver' command to automatically resolve "
            <> "dependencies and update the config file."

    cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir
    gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter

    (r, flags, extraDeps) <-
        getDefaultResolver dest (map parent cabalfps) gpds initOpts
    let p = Project
            { projectPackages = pkgs
            , projectExtraDeps = extraDeps
            , projectFlags = removeSrcPkgDefaultFlags gpds flags
            , projectResolver = r
            , projectCompiler = Nothing
            , projectExtraPackageDBs = []
            }
        pkgs = map toPkg cabalfps
        toPkg fp = PackageEntry
            { peValidWanted = Nothing
            , peExtraDepMaybe = Nothing
            , peLocation = PLFilePath $
                case stripDir currDir $ parent fp of
                    Nothing
                        | currDir == parent fp -> "."
                        | otherwise -> assert False $ toFilePath $ parent fp
                    Just rel -> toFilePath rel
            , peSubdirs = []
            }

    $logInfo $ "Initialising configuration using resolver: " <> resolverName r
    $logInfo $
        (if exists then "Overwriting existing configuration file: "
         else "Writing configuration to file: ")
        <> T.pack reldest
    liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p
    $logInfo "All done."

-- | Render a stack.yaml file with comments, see:
-- https://github.com/commercialhaskell/stack/issues/226
renderStackYaml :: Project -> B.Builder
renderStackYaml p =
    case Yaml.toJSON p of
        Yaml.Object o -> renderObject o
        _ -> assert False $ B.byteString $ Yaml.encode p
  where
    renderObject o =
        B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html\n\n" <>
        F.foldMap (goComment o) comments <>
        goOthers (o `HM.difference` HM.fromList comments) <>
        B.byteString
            "# Control whether we use the GHC we find on the path\n\
            \# system-ghc: true\n\n\
            \# Require a specific version of stack, using version ranges\n\
            \# require-stack-version: -any # Default\n\
            \# require-stack-version: >= 1.0.0\n\n\
            \# Override the architecture used by stack, especially useful on Windows\n\
            \# arch: i386\n\
            \# arch: x86_64\n\n\
            \# Extra directories used by stack for building\n\
            \# extra-include-dirs: [/path/to/dir]\n\
            \# extra-lib-dirs: [/path/to/dir]\n\n\
            \# Allow a newer minor version of GHC than the snapshot specifies\n\
            \# compiler-check: newer-minor\n"

    comments =
        [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")
        , ("packages", "Local packages, usually specified by relative directory name")
        , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)")
        , ("flags", "Override default flag values for local packages and extra-deps")
        , ("extra-package-dbs", "Extra package databases containing global packages")
        ]

    goComment o (name, comment) =
        case HM.lookup name o of
            Nothing -> assert False mempty
            Just v ->
                B.byteString "# " <>
                B.byteString comment <>
                B.byteString "\n" <>
                B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>
                B.byteString "\n"

    goOthers o
        | HM.null o = mempty
        | otherwise = assert False $ B.byteString $ Yaml.encode o

getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
              => m (Maybe Snapshots)
getSnapshots' =
    liftM Just getSnapshots `catchAny` \e -> do
        $logError $
            "Unable to download snapshot list, and therefore could " <>
            "not generate a stack.yaml file automatically"
        $logError $
            "This sometimes happens due to missing Certificate Authorities " <>
            "on your system. For more information, see:"
        $logError ""
        $logError "    https://github.com/commercialhaskell/stack/issues/234"
        $logError ""
        $logError "You can try again, or create your stack.yaml file by hand. See:"
        $logError ""
        $logError "    http://docs.haskellstack.org/en/stable/yaml_configuration.html"
        $logError ""
        $logError $ "Exception was: " <> T.pack (show e)
        return Nothing

-- | Get the default resolver value
getDefaultResolver
    :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m
       , MonadReader env m, HasConfig env , HasGHCVariant env
       , HasHttpManager env , HasLogLevel env , HasReExec env
       , HasTerminal env)
    => Path Abs File   -- ^ stack.yaml
    -> [Path Abs Dir]  -- ^ cabal dirs
    -> [C.GenericPackageDescription] -- ^ cabal descriptions
    -> InitOpts
    -> m ( Resolver
         , Map PackageName (Map FlagName Bool)
         , Map PackageName Version)
getDefaultResolver stackYaml cabalDirs gpds initOpts = do
    resolver <- getResolver (ioMethod initOpts)
    result   <- checkResolverSpec gpds Nothing resolver

    case result of
        BuildPlanCheckOk f-> return (resolver, f, Map.empty)
        BuildPlanCheckPartial f e
            | needSolver resolver initOpts -> solve (resolver, f)
            | otherwise ->
                throwM $ ResolverPartial resolver (showDepErrors f e)
        BuildPlanCheckFail f e c ->
            throwM $ ResolverMismatch resolver (showCompilerErrors f e c)

    where
      solve (res, f) = do
          let srcConstraints = mergeConstraints (gpdPackages gpds) f
          mresolver <- solveResolverSpec stackYaml cabalDirs
                                         (res, srcConstraints, Map.empty)
          case mresolver of
              Just (src, ext) -> do
                  return (res, fmap snd (Map.union src ext), fmap fst ext)
              Nothing
                  | forceOverwrite initOpts -> do
                      $logWarn "\nSolver could not arrive at a workable build \
                               \plan.\nProceeding to create a config with an \
                               \incomplete plan anyway..."
                      return (res, f, Map.empty)
                  | otherwise -> throwM (SolverGiveUp giveUpMsg)

      giveUpMsg = concat
          [ "    - Use '--ignore-subdirs' to skip packages in subdirectories.\n"
          , "    - Update external packages with 'stack update' and try again.\n"
          , "    - Use '--force' to create an initial "
          , toFilePath stackDotYaml <> ", tweak it and run 'stack solver':\n"
          , "        - Remove any unnecessary packages.\n"
          , "        - Add any missing remote packages.\n"
          , "        - Add extra dependencies to guide solver.\n"
          ]

      -- TODO support selecting best across regular and custom snapshots
      getResolver (MethodSnapshot snapPref)  = selectSnapResolver snapPref
      getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver

      selectSnapResolver snapPref = do
          msnaps <- getSnapshots'
          snaps <- maybe (error "No snapshots to select from.")
                         (getRecommendedSnapshots snapPref)
                         msnaps
          selectBestSnapshot gpds snaps
            >>= maybe (throwM (NoMatchingSnapshot snaps))
                      (return . ResolverSnapshot)

      needSolver _ (InitOpts {useSolver = True}) = True
      needSolver (ResolverCompiler _)  _ = True
      needSolver _ _ = False

getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)
                        => SnapPref
                        -> Snapshots
                        -> m [SnapName]
getRecommendedSnapshots pref snapshots = do
    -- Get the most recent LTS and Nightly in the snapshots directory and
    -- prefer them over anything else, since odds are high that something
    -- already exists for them.
    existing <-
        liftM (sortBy (flip compare) . mapMaybe (parseSnapName . T.pack)) $
        snapshotsDir >>=
        liftIO . handleIO (const $ return [])
               . getDirectoryContents . toFilePath
    let isLTS LTS{} = True
        isLTS Nightly{} = False
        isNightly Nightly{} = True
        isNightly LTS{} = False

        names = nubOrd $ concat
            [ take 2 $ filter isLTS existing
            , take 2 $ filter isNightly existing
            , map (uncurry LTS)
                (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)
            , [Nightly $ snapshotsNightly snapshots]
            ]

        namesLTS = filter isLTS names
        namesNightly = filter isNightly names

    case pref of
        PrefNone -> return names
        PrefLTS -> return $ namesLTS ++ namesNightly
        PrefNightly -> return $ namesNightly ++ namesLTS

data InitOpts = InitOpts
    { ioMethod       :: !Method
    -- ^ Use solver
    , useSolver :: Bool
    -- ^ Preferred snapshots
    , forceOverwrite :: Bool
    -- ^ Overwrite existing files
    , includeSubDirs :: Bool
    -- ^ If True, include all .cabal files found in any sub directories
    }

data SnapPref = PrefNone | PrefLTS | PrefNightly

-- | Method of initializing
data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver