content: {-# LANGUAGE BangPatterns, OverloadedStrings #-}
  module Reporting
    ( Style
    , silent
    , json
    , terminal
    --
    , attempt
    , attemptWithStyle
    --
    , Key(..) -- @LAMDERA exposed
    , report
    , ignorer
    , ask
    --
    , DKey
    , DMsg(..)
    , trackDetails
    --
    , BKey
    , BMsg(..)
    , trackBuild
    --
    , reportGenerate
    , attemptWithStyle_cleanup -- @LAMDERA
    )
    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
  
  
  import qualified Lamdera
  import qualified Lamdera.Version
  
  -- 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")
              -- & Lamdera.alternativeImplementation (when (rqst == 0) (Lamdera.atomicPutStrLn "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
                  Lamdera.debug "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
                Lamdera.debug $ "\rCompiling (" ++ show done1 ++ ")"
                buildLoop chan done1
  
          Right result ->
            let
              !message = toFinalMessage done result
              !width = 12 + length (show done)
            in
            Lamdera.atomicPutStrLn $
              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."
  
          Exit.BuildLamderaProblem _ _ _ ->
            "Detected a Lamdera 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
            Lamdera.alternativeImplementation (pure ()) $
             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
      -- This seemed ideal, but it actually ruins line-overwriting progress i.e. the compile indicator
      -- so we need to be selective with what we actually override...
      -- & Lamdera.alternativeImplementation (Lamdera.atomicPutStrLn str)
  
  
  
  -- 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 $ Lamdera.Version.full
      , 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 Discord\
          \ https://dashboard.lamdera.app/docs/discuss 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."
      ]
  
  
  
  -- @LAMDERA
  
  -- Clone of Reporting.attemptWithStyle that allows for consistent cleanup
  attemptWithStyle_cleanup :: IO () -> Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
  attemptWithStyle_cleanup cleanup style toReport work =
    do  result <- work `catch` reportExceptionsNicely
        case result of
          Right a ->
            return a
  
          Left x ->
            case style of
              Silent ->
                do  cleanup
                    Exit.exitFailure
  
              Json ->
                do  B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
                    cleanup
                    Exit.exitFailure
  
              Terminal mvar ->
                do  readMVar mvar
                    Exit.toStderr (toReport x)
                    cleanup
                    Exit.exitFailure
  