{-# LANGUAGE GADTs, OverloadedStrings #-}
module Terminal.Error
  ( Error(..)
  , ArgError(..)
  , FlagError(..)
  , Expectation(..)
  , exitWithHelp
  , exitWithError
  , exitWithUnknown
  , exitWithOverview
  )
  where


import Data.Monoid ((<>))
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import GHC.IO.Handle (hIsTerminalDevice)
import qualified System.Environment as Env
import qualified System.Exit as Exit
import qualified System.FilePath as FP
import System.IO (hPutStrLn, stderr)
import qualified Text.PrettyPrint.ANSI.Leijen as P

import Reporting.Suggest as Suggest
import Terminal.Internal



-- ERROR


data Error where
  BadArgs :: [(CompleteArgs a, ArgError)] -> Error
  BadFlag :: FlagError -> Error


data ArgError
  = ArgMissing Expectation
  | ArgBad String Expectation
  | ArgExtras [String]


data FlagError where
  FlagWithValue :: String -> String -> FlagError
  FlagWithBadValue :: String -> String -> Expectation -> FlagError
  FlagWithNoValue :: String -> Expectation -> FlagError
  FlagUnknown :: String -> Flags a -> FlagError


data Expectation =
  Expectation
    { _type :: String
    , _examples :: IO [String]
    }



-- EXIT


exitSuccess :: [P.Doc] -> IO a
exitSuccess =
  exitWith Exit.ExitSuccess


exitFailure :: [P.Doc] -> IO a
exitFailure =
  exitWith (Exit.ExitFailure 1)


exitWith :: Exit.ExitCode -> [P.Doc] -> IO a
exitWith code docs =
  do  isTerminal <- hIsTerminalDevice stderr
      let adjust = if isTerminal then id else P.plain
      P.displayIO stderr $ P.renderPretty 1 80 $
        adjust $ P.vcat $ concatMap (\d -> [d,""]) docs
      hPutStrLn stderr ""
      Exit.exitWith code


getExeName :: IO String
getExeName =
  FP.takeFileName <$> Env.getProgName


stack :: [P.Doc] -> P.Doc
stack docs =
  P.vcat $ List.intersperse "" docs


reflow :: String -> P.Doc
reflow string =
  P.fillSep $ map P.text $ words string



-- HELP


exitWithHelp :: Maybe String -> String -> P.Doc -> Args args -> Flags flags -> IO a
exitWithHelp maybeCommand details example (Args args) flags =
  do  command <- toCommand maybeCommand
      exitSuccess $
        [ reflow details
        , P.indent 4 $ P.cyan $ P.vcat $ map (argsToDoc command) args
        , example
        ]
        ++
          case flagsToDocs flags [] of
            [] ->
              []

            docs@(_:_) ->
              [ "You can customize this command with the following flags:"
              , P.indent 4 $ stack docs
              ]


toCommand :: Maybe String -> IO String
toCommand maybeCommand =
  do  exeName <- getExeName
      return $
        case maybeCommand of
          Nothing ->
            exeName

          Just command ->
            exeName ++ " " ++ command


argsToDoc :: String -> CompleteArgs a -> P.Doc
argsToDoc command args =
  case args of
    Exactly required ->
      argsToDocHelp command required []

    Multiple required (Parser _ plural _ _ _) ->
      argsToDocHelp command required ["zero or more " ++ plural]

    Optional required (Parser singular _ _ _ _) ->
      argsToDocHelp command required ["optional " ++ singular]


argsToDocHelp :: String -> RequiredArgs a -> [String] -> P.Doc
argsToDocHelp command args names =
  case args of
    Done _ ->
      P.hang 4 $ P.hsep $ map P.text $
        command : map toToken names

    Required others (Parser singular _ _ _ _) ->
      argsToDocHelp command others (singular : names)


toToken :: String -> String
toToken string =
  "<" ++ map (\c -> if c == ' ' then '-' else c) string ++ ">"


flagsToDocs :: Flags flags -> [P.Doc] -> [P.Doc]
flagsToDocs flags docs =
  case flags of
    FDone _ ->
      docs

    FMore more flag ->
      let
        flagDoc =
          P.vcat $
            case flag of
              Flag name (Parser singular _ _ _ _) description ->
                [ P.dullcyan $ P.text $ "--" ++ name ++ "=" ++ toToken singular
                , P.indent 4 $ reflow description
                ]

              OnOff name description ->
                [ P.dullcyan $ P.text $ "--" ++ name
                , P.indent 4 $ reflow description
                ]
      in
      flagsToDocs more (flagDoc:docs)



-- OVERVIEW


exitWithOverview :: P.Doc -> P.Doc -> [Command] -> IO a
exitWithOverview intro outro commands =
  do  exeName <- getExeName
      exitSuccess
        [ intro
        , "The most common commands are:"
        , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) commands
        , "There are a bunch of other commands as well though. Here is a full list:"
        , P.indent 4 $ P.dullcyan $ toCommandList exeName commands
        , "Adding the --help flag gives a bunch of additional details about each one."
        , outro
        ]


toSummary :: String -> Command -> Maybe P.Doc
toSummary exeName (Command name summary _ _ (Args args) _ _) =
  case summary of
    Uncommon ->
      Nothing

    Common summaryString ->
      Just $
        P.vcat
          [ P.cyan $ argsToDoc (exeName ++ " " ++ name) (head args)
          , P.indent 4 $ reflow summaryString
          ]


toCommandList :: String -> [Command] -> P.Doc
toCommandList exeName commands =
  let
    names = map toName commands
    width = maximum (map length names)

    toExample name =
      P.text $ exeName ++ " " ++ name ++ replicate (width - length name) ' ' ++ " --help"
  in
  P.vcat (map toExample names)



-- UNKNOWN


exitWithUnknown :: String -> [String] -> IO a
exitWithUnknown unknown knowns =
  let
    nearbyKnowns =
      takeWhile (\(r,_) -> r <= 3) (Suggest.rank unknown id knowns)

    suggestions =
      case map toGreen (map snd nearbyKnowns) of
        [] ->
          []

        [nearby] ->
          ["Try",nearby,"instead?"]

        [a,b] ->
          ["Try",a,"or",b,"instead?"]

        abcs@(_:_:_:_) ->
          ["Try"] ++ map (<> ",") (init abcs) ++ ["or",last abcs,"instead?"]
  in
  do  exeName <- getExeName
      exitFailure
        [ P.fillSep $ ["There","is","no",toRed unknown,"command."] ++ suggestions
        , reflow $ "Run `" ++ exeName ++ "` with no arguments to get more hints."
        ]



-- ERROR TO DOC


exitWithError :: Error -> IO a
exitWithError err =
  exitFailure =<<
    case err of
      BadFlag flagError ->
        flagErrorToDocs flagError

      BadArgs argErrors ->
        case argErrors of
          [] ->
            return
              [ reflow $ "I was not expecting any arguments for this command."
              , reflow $ "Try removing them?"
              ]

          [(_args, argError)] ->
            argErrorToDocs argError

          _:_:_ ->
            argErrorToDocs $ head $ List.sortOn toArgErrorRank (map snd argErrors)


toArgErrorRank :: ArgError -> Int -- lower is better
toArgErrorRank err =
  case err of
    ArgBad _ _   -> 0
    ArgMissing _ -> 1
    ArgExtras _  -> 2


toGreen :: String -> P.Doc
toGreen str =
  P.green (P.text str)


toYellow :: String -> P.Doc
toYellow str =
  P.yellow (P.text str)


toRed :: String -> P.Doc
toRed str =
  P.red (P.text str)



-- ARG ERROR TO DOC


argErrorToDocs :: ArgError -> IO [P.Doc]
argErrorToDocs argError =
  case argError of
    ArgMissing (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          return
            [ P.fillSep
                ["The","arguments","you","have","are","fine,","but","in","addition,","I","was"
                ,"expecting","a",toYellow (toToken tipe),"value.","For","example:"
                ]
            , P.indent 4 $ P.green $ P.vcat $ map P.text examples
            ]

    ArgBad string (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          return
            [ "I am having trouble with this argument:"
            , P.indent 4 $ toRed string
            , P.fillSep $
                ["It","is","supposed","to","be","a"
                ,toYellow (toToken tipe),"value,","like"
                ] ++ if length examples == 1 then ["this:"] else ["one","of","these:"]
            , P.indent 4 $ P.green $ P.vcat $ map P.text examples
            ]

    ArgExtras extras ->
      let
        (these, them) =
          case extras of
            [_] -> ("this argument", "it")
            _ -> ("these arguments", "them")
      in
      return
        [ reflow $ "I was not expecting " ++ these ++ ":"
        , P.indent 4 $ P.red $ P.vcat $ map P.text extras
        , reflow $ "Try removing " ++ them ++ "?"
        ]



-- FLAG ERROR TO DOC


flagErrorHelp :: String -> String -> [P.Doc] -> IO [P.Doc]
flagErrorHelp summary original explanation =
  return $
    [ reflow summary
    , P.indent 4 (toRed original)
    ]
    ++ explanation


flagErrorToDocs :: FlagError -> IO [P.Doc]
flagErrorToDocs flagError =
  case flagError of
    FlagWithValue flagName value ->
      flagErrorHelp
        "This on/off flag was given a value:"
        ("--" ++ flagName ++ "=" ++ value)
        [ "An on/off flag either exists or not. It cannot have an equals sign and value.\n\
          \Maybe you want this instead?"
        , P.indent 4 $ toGreen $ "--" ++ flagName
        ]

    FlagWithNoValue flagName (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          flagErrorHelp
            "This flag needs more information:"
            ("--" ++ flagName)
            [ P.fillSep ["It","needs","a",toYellow (toToken tipe),"like","this:"]
            , P.indent 4 $ P.vcat $ map toGreen $
                case take 4 examples of
                  [] ->
                    ["--" ++ flagName ++ "=" ++ toToken tipe]

                  _:_ ->
                    map (\example -> "--" ++ flagName ++ "=" ++ example) examples
            ]

    FlagWithBadValue flagName badValue (Expectation tipe makeExamples) ->
      do  examples <- makeExamples
          flagErrorHelp
            "This flag was given a bad value:"
            ("--" ++ flagName ++ "=" ++ badValue)
            [ P.fillSep $
                ["I","need","a","valid",toYellow (toToken tipe),"value.","For","example:"
                ]
            , P.indent 4 $ P.vcat $ map toGreen $
                case take 4 examples of
                  [] ->
                    ["--" ++ flagName ++ "=" ++ toToken tipe]

                  _:_ ->
                    map (\example -> "--" ++ flagName ++ "=" ++ example) examples
            ]

    FlagUnknown unknown flags ->
      flagErrorHelp
        "I do not recognize this flag:"
        unknown
        (
          let unknownName = takeWhile ('=' /=) (dropWhile ('-' ==) unknown) in
          case getNearbyFlags unknownName flags [] of
            [] ->
              []

            [thisOne] ->
              [ P.fillSep ["Maybe","you","want",P.green thisOne,"instead?"]
              ]

            suggestions ->
              [ P.fillSep ["Maybe","you","want","one","of","these","instead?"]
              , P.indent 4 $ P.green $ P.vcat suggestions
              ]
        )


getNearbyFlags :: String -> Flags a -> [(Int, String)] -> [P.Doc]
getNearbyFlags unknown flags unsortedFlags =
  case flags of
    FMore more flag ->
      getNearbyFlags unknown more (getNearbyFlagsHelp unknown flag : unsortedFlags)

    FDone _ ->
      map P.text $ map snd $ List.sortOn fst $
        case filter (\(d,_) -> d < 3) unsortedFlags of
          [] ->
            unsortedFlags

          nearbyUnsortedFlags ->
            nearbyUnsortedFlags


getNearbyFlagsHelp :: String -> Flag a -> (Int, String)
getNearbyFlagsHelp unknown flag =
  case flag of
    OnOff flagName _ ->
      ( Suggest.distance unknown flagName
      , "--" ++ flagName
      )

    Flag flagName (Parser singular _ _ _ _) _ ->
      ( Suggest.distance unknown flagName
      , "--" ++ flagName ++ "=" ++ toToken singular
      )