{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Reporting
  ( Style
  , silent
  , json
  , terminal
  --
  , attempt
  , attemptWithStyle
  --
  , Key
  , report
  , ignorer
  , ask
  --
  , DKey
  , DMsg(..)
  , trackDetails
  --
  , BKey
  , BMsg(..)
  , trackBuild
  --
  , reportGenerate
  )
  where


import Control.Concurrent
import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
import Control.Monad (when)
import qualified Data.ByteString.Builder as B
import qualified Data.NonEmptyList as NE
import qualified System.Exit as Exit
import qualified System.Info as Info
import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)

import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified Json.Encode as Encode
import Reporting.Doc ((<+>), (<>))
import qualified Reporting.Doc as D
import qualified Reporting.Exit as Exit
import qualified Reporting.Exit.Help as Help



-- STYLE


data Style
  = Silent
  | Json
  | Terminal (MVar ())


silent :: Style
silent =
  Silent


json :: Style
json =
  Json


terminal :: IO Style
terminal =
  Terminal <$> newMVar ()



-- ATTEMPT


attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
attempt toReport work =
  do  result <- work `catch` reportExceptionsNicely
      case result of
        Right a ->
          return a

        Left x ->
          do  Exit.toStderr (toReport x)
              Exit.exitFailure


attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
attemptWithStyle style toReport work =
  do  result <- work `catch` reportExceptionsNicely
      case result of
        Right a ->
          return a

        Left x ->
          case style of
            Silent ->
              do  Exit.exitFailure

            Json ->
              do  B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
                  Exit.exitFailure

            Terminal mvar ->
              do  readMVar mvar
                  Exit.toStderr (toReport x)
                  Exit.exitFailure



-- MARKS


goodMark :: D.Doc
goodMark =
  D.green $ if isWindows then "+" else "●"


badMark :: D.Doc
badMark =
  D.red $ if isWindows then "X" else "✗"


isWindows :: Bool
isWindows =
  Info.os == "mingw32"



-- KEY


newtype Key msg = Key (msg -> IO ())


report :: Key msg -> msg -> IO ()
report (Key send) msg =
  send msg


ignorer :: Key msg
ignorer =
  Key (\_ -> return ())



-- ASK


ask :: D.Doc -> IO Bool
ask doc =
  do  Help.toStdout doc
      askHelp


askHelp :: IO Bool
askHelp =
  do  hFlush stdout
      input <- getLine
      case input of
        ""  -> return True
        "Y" -> return True
        "y" -> return True
        "n" -> return False
        _   ->
          do  putStr "Must type 'y' for yes or 'n' for no: "
              askHelp


-- DETAILS


type DKey = Key DMsg


trackDetails :: Style -> (DKey -> IO a) -> IO a
trackDetails style callback =
  case style of
    Silent ->
      callback (Key (\_ -> return ()))

    Json ->
      callback (Key (\_ -> return ()))

    Terminal mvar ->
      do  chan <- newChan

          _ <- forkIO $
            do  takeMVar mvar
                detailsLoop chan (DState 0 0 0 0 0 0 0)
                putMVar mvar ()

          answer <- callback (Key (writeChan chan . Just))
          writeChan chan Nothing
          return answer


detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
detailsLoop chan state@(DState total _ _ _ _ built _) =
  do  msg <- readChan chan
      case msg of
        Just dmsg ->
          detailsLoop chan =<< detailsStep dmsg state

        Nothing ->
          putStrLn $ clear (toBuildProgress total total) $
            if built == total
            then "Dependencies ready!"
            else "Dependency problem!"


data DState =
  DState
    { _total :: !Int
    , _cached :: !Int
    , _requested :: !Int
    , _received :: !Int
    , _failed :: !Int
    , _built :: !Int
    , _broken :: !Int
    }


data DMsg
  = DStart Int
  | DCached
  | DRequested
  | DReceived Pkg.Name V.Version
  | DFailed Pkg.Name V.Version
  | DBuilt
  | DBroken


detailsStep :: DMsg -> DState -> IO DState
detailsStep msg (DState total cached rqst rcvd failed built broken) =
  case msg of
    DStart numDependencies ->
      return (DState numDependencies 0 0 0 0 0 0)

    DCached ->
      putTransition (DState total (cached + 1) rqst rcvd failed built broken)

    DRequested ->
      do  when (rqst == 0) (putStrLn "Starting downloads...\n")
          return (DState total cached (rqst + 1) rcvd failed built broken)

    DReceived pkg vsn ->
      do  putDownload goodMark pkg vsn
          putTransition (DState total cached rqst (rcvd + 1) failed built broken)

    DFailed pkg vsn ->
      do  putDownload badMark pkg vsn
          putTransition (DState total cached rqst rcvd (failed + 1) built broken)

    DBuilt ->
      putBuilt (DState total cached rqst rcvd failed (built + 1) broken)

    DBroken ->
      putBuilt (DState total cached rqst rcvd failed built (broken + 1))


putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
putDownload mark pkg vsn =
  Help.toStdout $ D.indent 2 $
    mark
    <+> D.fromPackage pkg
    <+> D.fromVersion vsn
    <> "\n"


putTransition :: DState -> IO DState
putTransition state@(DState total cached _ rcvd failed built broken) =
  if cached + rcvd + failed < total then
    return state

  else
    do  let char = if rcvd + failed == 0 then '\r' else '\n'
        putStrFlush (char : toBuildProgress (built + broken + failed) total)
        return state


putBuilt :: DState -> IO DState
putBuilt state@(DState total cached _ rcvd failed built broken) =
  do  when (total == cached + rcvd + failed) $
        putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
      return state


toBuildProgress :: Int -> Int -> [Char]
toBuildProgress built total =
  "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"


clear :: [Char] -> [Char] -> [Char]
clear before after =
  '\r' : replicate (length before) ' ' ++ '\r' : after



-- BUILD


type BKey = Key BMsg

type BResult a = Either Exit.BuildProblem a


trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
trackBuild style callback =
  case style of
    Silent ->
      callback (Key (\_ -> return ()))

    Json ->
      callback (Key (\_ -> return ()))

    Terminal mvar ->
      do  chan <- newChan

          _ <- forkIO $
            do  takeMVar mvar
                putStrFlush "Compiling ..."
                buildLoop chan 0
                putMVar mvar ()

          result <- callback (Key (writeChan chan . Left))
          writeChan chan (Right result)
          return result


data BMsg
  = BDone


buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
buildLoop chan done =
  do  msg <- readChan chan
      case msg of
        Left BDone ->
          do  let !done1 = done + 1
              putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
              buildLoop chan done1

        Right result ->
          let
            !message = toFinalMessage done result
            !width = 12 + length (show done)
          in
          putStrLn $
            if length message < width
            then '\r' : replicate width ' ' ++ '\r' : message
            else '\r' : message


toFinalMessage :: Int -> BResult a -> [Char]
toFinalMessage done result =
  case result of
    Right _ ->
      case done of
        0 -> "Success!"
        1 -> "Success! Compiled 1 module."
        n -> "Success! Compiled " ++ show n ++ " modules."

    Left problem ->
      case problem of
        Exit.BuildBadModules _ _ [] ->
          "Detected problems in 1 module."

        Exit.BuildBadModules _ _ (_:ps) ->
          "Detected problems in " ++ show (2 + length ps) ++ " modules."

        Exit.BuildProjectProblem _ ->
          "Detected a problem."



-- GENERATE


reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
reportGenerate style names output =
  case style of
    Silent ->
      return ()

    Json ->
      return ()

    Terminal mvar ->
      do  readMVar mvar
          let cnames = fmap ModuleName.toChars names
          putStrLn ('\n' : toGenDiagram cnames output)


toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
toGenDiagram (NE.List name names) output =
  let
    width = 3 + foldr (max . length) (length name) names
  in
  case names of
    [] ->
      toGenLine width name ('>' : ' ' : output ++ "\n")

    _:_ ->
      unlines $
        toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
        : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))


toGenLine :: Int -> [Char] -> [Char] -> [Char]
toGenLine width name end =
  "    " ++ name ++ ' ' : replicate (width - length name) hbar ++ end


hbar :: Char
hbar = if isWindows then '-' else '─'

vtop :: Char
vtop = if isWindows then '+' else '┬'

vmiddle :: Char
vmiddle = if isWindows then '+' else '┤'

vbottom :: Char
vbottom = if isWindows then '+' else '┘'


--


putStrFlush :: String -> IO ()
putStrFlush str =
  hPutStr stdout str >> hFlush stdout



-- REPORT EXCEPTIONS NICELY


reportExceptionsNicely :: SomeException -> IO a
reportExceptionsNicely e =
  case fromException e of
    Just UserInterrupt -> throw e
    _                  -> putException e >> throw e


putException :: SomeException -> IO ()
putException e = do
  hPutStrLn stderr ""
  Help.toStderr $ D.stack $
    [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
    , D.reflow $
        "I ran into something that bypassed the normal error reporting process!\
        \ I extracted whatever information I could from the internal error:"
    , D.vcat $ map (\line -> D.red ">" <> "   " <> D.fromChars line) (lines (show e))
    , D.reflow $
        "These errors are usually pretty confusing, so start by asking around on one of\
        \ forums listed at https://elm-lang.org/community to see if anyone can get you\
        \ unstuck quickly."
    , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
    , D.reflow $
        "If you are feeling up to it, please try to get your code down to the smallest\
        \ version that still triggers this message. Ideally in a single Main.elm and\
        \ elm.json file."
    , D.reflow $
        "From there open a NEW issue at https://github.com/elm/compiler/issues with\
        \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
        \ worry about if someone else saw something similar. More examples is better!"
    , D.reflow $
        "This kind of error is usually tied up in larger architectural choices that are\
        \ hard to change, so even when we have a couple good examples, it can take some\
        \ time to resolve in a solid way."
    ]
