{-# LANGUAGE OverloadedStrings #-}
module Install
  ( Args(..)
  , run
  )
  where


import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Map.Merge.Strict as Map

import qualified Deps.Solver as Solver
import qualified Deps.Registry as Registry
import qualified Elm.Constraint as C
import qualified Elm.Details as Details
import qualified Elm.Package as Pkg
import qualified Elm.Outline as Outline
import qualified Elm.Version as V
import qualified Reporting
import Reporting.Doc ((<>), (<+>))
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit
import qualified Reporting.Task as Task
import qualified Stuff



-- RUN


data Args
  = NoArgs
  | Install Pkg.Name


run :: Args -> () -> IO ()
run args () =
  Reporting.attempt Exit.installToReport $
    do  maybeRoot <- Stuff.findRoot
        case maybeRoot of
          Nothing ->
            return (Left Exit.InstallNoOutline)

          Just root ->
            case args of
              NoArgs ->
                do  elmHome <- Stuff.getElmHome
                    return (Left (Exit.InstallNoArgs elmHome))

              Install pkg ->
                Task.run $
                  do  env <- Task.eio Exit.InstallBadRegistry $ Solver.initEnv
                      oldOutline <- Task.eio Exit.InstallBadOutline $ Outline.read root
                      case oldOutline of
                        Outline.App outline ->
                          do  changes <- makeAppPlan env pkg outline
                              attemptChanges root env pkg oldOutline V.toChars changes

                        Outline.Pkg outline ->
                          do  changes <- makePkgPlan env pkg outline
                              attemptChanges root env pkg oldOutline C.toChars changes



-- ATTEMPT CHANGES


data Changes vsn
  = AlreadyInstalled
  | PromoteTest Outline.Outline
  | PromoteIndirect Outline.Outline
  | Changes (Map.Map Pkg.Name (Change vsn)) Outline.Outline


type Task = Task.Task Exit.Install


attemptChanges :: FilePath -> Solver.Env -> Pkg.Name -> Outline.Outline -> (a -> String) -> Changes a -> Task ()
attemptChanges root env pkg oldOutline toChars changes =
  case changes of
    AlreadyInstalled ->
      Task.io $ putStrLn "It is already installed!"

    PromoteIndirect newOutline ->
      attemptChangesHelp root env pkg oldOutline newOutline $
        D.vcat
         [ D.fillSep
            ["I","found","it","in","your","elm.json","file,"
            ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
            ]
         , D.fillSep
            ["Should","I","move","it","into",D.green "\"direct\""
            ,"dependencies","for","more","general","use?","[Y/n]: "
            ]
         ]

    PromoteTest newOutline ->
      attemptChangesHelp root env pkg oldOutline newOutline $
        D.vcat
         [ D.fillSep
            ["I","found","it","in","your","elm.json","file,"
            ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
            ]
         , D.fillSep
            ["Should","I","move","it","into",D.green "\"dependencies\""
            ,"for","more","general","use?","[Y/n]: "
            ]
         ]

    Changes changeDict newOutline ->
      let
        widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
        changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
      in
      attemptChangesHelp root env pkg oldOutline newOutline $ D.vcat $
        [ "Here is my plan:"
        , viewChangeDocs changeDocs
        , ""
        , "Would you like me to update your elm.json accordingly? [Y/n]: "
        ]


attemptChangesHelp :: FilePath -> Solver.Env -> Pkg.Name -> Outline.Outline -> Outline.Outline -> D.Doc -> Task ()
attemptChangesHelp root env pkg oldOutline newOutline question =
  Task.eio (\_ -> Exit.InstallHasBadDetails pkg (Outline.encode newOutline)) $
  do  approved <- Reporting.ask question
      if approved
        then
          do  Outline.write root newOutline
              result <- Details.verifyInstall root env newOutline
              case result of
                Left exit ->
                  do  Outline.write root oldOutline
                      return (Left exit)

                Right () ->
                  do  putStrLn "Success!"
                      return (Right ())
        else
          do  putStrLn "Okay, I did not change anything!"
              return (Right ())



-- MAKE APP PLAN


makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version)
makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
  if Map.member pkg direct then
    return AlreadyInstalled

  else
    -- is it already indirect?
    case Map.lookup pkg indirect of
      Just vsn ->
        return $ PromoteIndirect $ Outline.App $
          outline
            { Outline._app_deps_direct = Map.insert pkg vsn direct
            , Outline._app_deps_indirect = Map.delete pkg indirect
            }

      Nothing ->
        -- is it already a test dependency?
        case Map.lookup pkg testDirect of
          Just vsn ->
            return $ PromoteTest $ Outline.App $
              outline
                { Outline._app_deps_direct = Map.insert pkg vsn direct
                , Outline._app_test_direct = Map.delete pkg testDirect
                }

          Nothing ->
            -- is it already an indirect test dependency?
            case Map.lookup pkg testIndirect of
              Just vsn ->
                return $ PromoteTest $ Outline.App $
                  outline
                    { Outline._app_deps_direct = Map.insert pkg vsn direct
                    , Outline._app_test_indirect = Map.delete pkg testIndirect
                    }

              Nothing ->
                -- finally try to add it from scratch
                case Registry.getVersions' pkg registry of
                  Left suggestions ->
                    case connection of
                      Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
                      Solver.Offline  -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)

                  Right _ ->
                    do  result <- Task.io $ Solver.addToApp cache connection registry pkg outline
                        case result of
                          Solver.Ok (Solver.AppSolution old new app) ->
                            return (Changes (detectChanges old new) (Outline.App app))

                          Solver.NoSolution ->
                            Task.throw Exit.InstallNoOnlineSolution

                          Solver.NoOfflineSolution ->
                            Task.throw Exit.InstallNoOfflineSolution

                          Solver.Err exit ->
                            Task.throw (Exit.InstallHadSolverTrouble exit)



-- MAKE PACKAGE PLAN


makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint)
makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) =
  if Map.member pkg deps then
    return AlreadyInstalled
  else
    -- is already in test dependencies?
    case Map.lookup pkg test of
      Just con ->
        return $ PromoteTest $ Outline.Pkg $
          outline
            { Outline._pkg_deps = Map.insert pkg con deps
            , Outline._pkg_test_deps = Map.delete pkg test
            }

      Nothing ->
        -- try to add a new dependency
        case Registry.getVersions' pkg registry of
          Left suggestions ->
            case connection of
              Solver.Online _ -> Task.throw (Exit.InstallUnknownPackageOnline pkg suggestions)
              Solver.Offline  -> Task.throw (Exit.InstallUnknownPackageOffline pkg suggestions)

          Right (Registry.KnownVersions _ _) ->
            do  let old = Map.union deps test
                let cons = Map.insert pkg C.anything old
                result <- Task.io $ Solver.verify cache connection registry cons
                case result of
                  Solver.Ok solution ->
                    let
                      (Solver.Details vsn _) = solution ! pkg

                      con = C.untilNextMajor vsn
                      new = Map.insert pkg con old
                      changes = detectChanges old new
                      news = Map.mapMaybe keepNew changes
                    in
                    return $ Changes changes $ Outline.Pkg $
                      outline
                        { Outline._pkg_deps = addNews (Just pkg) news deps
                        , Outline._pkg_test_deps = addNews Nothing news test
                        }

                  Solver.NoSolution ->
                    Task.throw Exit.InstallNoOnlineSolution

                  Solver.NoOfflineSolution ->
                    Task.throw Exit.InstallNoOfflineSolution

                  Solver.Err exit ->
                    Task.throw (Exit.InstallHadSolverTrouble exit)


addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint -> Map.Map Pkg.Name C.Constraint
addNews pkg new old =
  Map.merge
    Map.preserveMissing
    (Map.mapMaybeMissing (\k c -> if Just k == pkg then Just c else Nothing))
    (Map.zipWithMatched (\_ _ n -> n))
    old
    new



-- CHANGES


data Change a
  = Insert a
  | Change a a
  | Remove a


detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
detectChanges old new =
  Map.merge
    (Map.mapMissing (\_ v -> Remove v))
    (Map.mapMissing (\_ v -> Insert v))
    (Map.zipWithMaybeMatched keepChange)
    old
    new


keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
keepChange _ old new =
  if old == new then
    Nothing
  else
    Just (Change old new)


keepNew :: Change a -> Maybe a
keepNew change =
  case change of
    Insert a ->
      Just a

    Change _ a ->
      Just a

    Remove _ ->
      Nothing



-- VIEW CHANGE DOCS


data ChangeDocs =
  Docs
    { _doc_inserts :: [D.Doc]
    , _doc_changes :: [D.Doc]
    , _doc_removes :: [D.Doc]
    }


viewChangeDocs :: ChangeDocs -> D.Doc
viewChangeDocs (Docs inserts changes removes) =
  D.indent 2 $ D.vcat $ concat $
    [ viewNonZero "Add:"    inserts
    , viewNonZero "Change:" changes
    , viewNonZero "Remove:" removes
    ]


viewNonZero :: String -> [D.Doc] -> [D.Doc]
viewNonZero title entries =
  if null entries then
    []
  else
    [ ""
    , D.fromChars title
    , D.indent 2 (D.vcat entries)
    ]



-- VIEW CHANGE


addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
addChange toChars widths name change (Docs inserts changes removes) =
  case change of
    Insert new ->
      Docs (viewInsert toChars widths name new : inserts) changes removes

    Change old new ->
      Docs inserts (viewChange toChars widths name old new : changes) removes

    Remove old ->
      Docs inserts changes (viewRemove toChars widths name old : removes)


viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
viewInsert toChars (Widths nameWidth leftWidth _) name new =
  viewName nameWidth name <+> pad leftWidth (toChars new)


viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
  D.hsep
    [ viewName nameWidth name
    , pad leftWidth (toChars old)
    , "=>"
    , pad rightWidth (toChars new)
    ]


viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
viewRemove toChars (Widths nameWidth leftWidth _) name old =
  viewName nameWidth name <+> pad leftWidth (toChars old)


viewName :: Int -> Pkg.Name -> D.Doc
viewName width name =
  D.fill (width + 3) (D.fromPackage name)


pad :: Int -> String -> D.Doc
pad width string =
  D.fromChars (replicate (width - length string) ' ') <> D.fromChars string



-- WIDTHS


data Widths =
  Widths
    { _name :: !Int
    , _left :: !Int
    , _right :: !Int
    }


widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
widen toChars pkg change (Widths name left right) =
  let
    toLength a =
      length (toChars a)

    newName =
      max name (length (Pkg.toChars pkg))
  in
    case change of
      Insert new ->
        Widths newName (max left (toLength new)) right

      Change old new ->
        Widths newName (max left (toLength old)) (max right (toLength new))

      Remove old ->
        Widths newName (max left (toLength old)) right