content: {-# OPTIONS_GHC -Wall #-}
  {-# LANGUAGE OverloadedStrings #-}
  module Reporting.Doc
    ( P.Doc
    , (P.<+>), (<>)
    , P.align, P.cat, P.empty, P.fill, P.fillSep, P.hang
    , P.hcat, P.hsep, P.indent, P.sep, P.vcat
    , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow
    , P.dullred, P.dullcyan, P.dullyellow, P.dullgreen
    --
    , fromChars
    , fromName
    , fromVersion
    , fromPackage
    , fromInt
    --
    , toAnsi
    , toString
    , toLine
    --
    , encode
    --
    , stack
    , reflow
    , commaSep
    --
    , toSimpleNote
    , toFancyNote
    , toSimpleHint
    , toFancyHint
    --
    , link
    , fancyLink
    , reflowLink
    , makeLink
    , makeNakedLink
    --
    , args
    , moreArgs
    , ordinal
    , intToOrdinal
    , cycle
    )
    where
  
  
  import Prelude hiding (cycle)
  import qualified Data.List as List
  import Data.Monoid ((<>))
  import qualified Data.Name as Name
  import qualified System.Console.ANSI.Types as Ansi
  import qualified System.Info as Info
  import System.IO (Handle)
  import qualified Text.PrettyPrint.ANSI.Leijen as P
  
  import qualified Data.Index as Index
  import qualified Elm.Package as Pkg
  import qualified Elm.Version as V
  import Json.Encode ((==>))
  import qualified Json.Encode as E
  import qualified Json.String as Json
  
  import Lamdera
  
  -- FROM
  
  
  fromChars :: String -> P.Doc
  fromChars =
    P.text
  
  
  fromName :: Name.Name -> P.Doc
  fromName name =
    P.text (Name.toChars name)
  
  
  fromVersion :: V.Version -> P.Doc
  fromVersion vsn =
    P.text (V.toChars vsn)
  
  
  fromPackage :: Pkg.Name -> P.Doc
  fromPackage pkg =
    P.text (Pkg.toChars pkg)
  
  
  fromInt :: Int -> P.Doc
  fromInt n =
    P.text (show n)
  
  
  
  -- TO STRING
  
  
  toAnsi :: Handle -> P.Doc -> IO ()
  toAnsi handle doc =
    P.displayIO handle (P.renderPretty 1 80 doc)
  
  
  toString :: P.Doc -> String
  toString doc =
    P.displayS (P.renderPretty 1 80 (P.plain doc)) ""
  
  
  toLine :: P.Doc -> String
  toLine doc =
    P.displayS (P.renderPretty 1 (div maxBound 2) (P.plain doc)) ""
  
  
  
  -- FORMATTING
  
  
  stack :: [P.Doc] -> P.Doc
  stack docs =
    P.vcat (List.intersperse "" docs)
  
  
  reflow :: String -> P.Doc
  reflow paragraph =
    P.fillSep (map P.text (words paragraph))
  
  
  commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc]
  commaSep conjunction addStyle names =
    case names of
      [name] ->
        [ addStyle name ]
  
      [name1,name2] ->
        [ addStyle name1, conjunction, addStyle name2 ]
  
      _ ->
        map (\name -> addStyle name <> ",") (init names)
        ++
        [ conjunction
        , addStyle (last_ names (P.text "[empty names list!]"))
        ]
  
  
  
  -- NOTES
  
  
  toSimpleNote :: String -> P.Doc
  toSimpleNote message =
    toFancyNote (map P.text (words message))
  
  
  toFancyNote :: [P.Doc] -> P.Doc
  toFancyNote chunks =
    P.fillSep (P.underline "Note" <> ":" : chunks)
  
  
  
  -- HINTS
  
  
  toSimpleHint :: String -> P.Doc
  toSimpleHint message =
    toFancyHint (map P.text (words message))
  
  
  toFancyHint :: [P.Doc] -> P.Doc
  toFancyHint chunks =
    P.fillSep (P.underline "Hint" <> ":" : chunks)
  
  
  
  -- LINKS
  
  
  link :: String -> String -> String -> String -> P.Doc
  link word before fileName after =
    P.fillSep $
      (P.underline (P.text word) <> ":")
      : map P.text (words before)
      ++ P.text (makeLink fileName)
      : map P.text (words after)
  
  
  fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
  fancyLink word before fileName after =
    P.fillSep $
      (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after
  
  
  makeLink :: [Char] -> [Char]
  makeLink fileName =
    "<https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName <> ">"
  
  
  makeNakedLink :: [Char] -> [Char]
  makeNakedLink fileName =
    "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName
  
  
  reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
  reflowLink before fileName after =
    P.fillSep $
      map P.text (words before)
      ++ P.text (makeLink fileName)
      : map P.text (words after)
  
  
  
  -- HELPERS
  
  
  args :: Int -> String
  args n =
    show n <> if n == 1 then " argument" else " arguments"
  
  
  moreArgs :: Int -> String
  moreArgs n =
    show n <> " more" <> if n == 1 then " argument" else " arguments"
  
  
  ordinal :: Index.ZeroBased -> String
  ordinal index =
    intToOrdinal (Index.toHuman index)
  
  
  intToOrdinal :: Int -> String
  intToOrdinal number =
    let
      remainder10 =
        number `mod` 10
  
      remainder100 =
        number `mod` 100
  
      ending
        | remainder100 `elem` [11..13] = "th"
        | remainder10 == 1             = "st"
        | remainder10 == 2             = "nd"
        | remainder10 == 3             = "rd"
        | otherwise                    = "th"
    in
      show number <> ending
  
  
  
  cycle :: Int -> Name.Name -> [Name.Name] -> P.Doc
  cycle indent name names =
    let
      toLn n = cycleLn <> P.dullyellow (fromName n)
    in
    P.indent indent $ P.vcat $
      cycleTop : List.intersperse cycleMid (toLn name : map toLn names) ++ [ cycleEnd ]
  
  
  cycleTop, cycleLn, cycleMid, cycleEnd :: P.Doc
  cycleTop = if isWindows then "+-----+" else "┌─────┐"
  cycleLn  = if isWindows then "|    "   else "│    "
  cycleMid = if isWindows then "|     |" else "│     ↓"
  cycleEnd = if isWindows then "+-<---+" else "└─────┘"
  
  
  isWindows :: Bool
  isWindows =
    Info.os == "mingw32"
  
  
  
  -- JSON
  
  
  encode :: P.Doc -> E.Value
  encode doc =
    E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc))
  
  
  data Style =
    Style
      { _bold :: Bool
      , _underline :: Bool
      , _color :: Maybe Color
      }
  
  
  noStyle :: Style
  noStyle =
    Style False False Nothing
  
  
  data Color
    = Red
    | RED
    | Magenta
    | MAGENTA
    | Yellow
    | YELLOW
    | Green
    | GREEN
    | Cyan
    | CYAN
    | Blue
    | BLUE
    | Black
    | BLACK
    | White
    | WHITE
  
  
  toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
  toJsonHelp style revChunks simpleDoc =
    case simpleDoc of
      P.SFail ->
        error $
          "according to the main implementation, @SFail@ can not\
          \ appear uncaught in a rendered @SimpleDoc@"
  
      P.SEmpty ->
        [ encodeChunks style revChunks ]
  
      P.SChar char rest ->
        toJsonHelp style ([char] : revChunks) rest
  
      P.SText _ string rest ->
        toJsonHelp style (string : revChunks) rest
  
      P.SLine indent rest ->
        toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest
  
      P.SSGR sgrs rest ->
        encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
  
  
  sgrToStyle :: [Ansi.SGR] -> Style -> Style
  sgrToStyle sgrs style@(Style bold underline color) =
    case sgrs of
      [] ->
        style
  
      sgr : rest ->
        sgrToStyle rest $
          case sgr of
            Ansi.Reset                         -> noStyle
            Ansi.SetConsoleIntensity i         -> Style (isBold i) underline color
            Ansi.SetItalicized _               -> style
            Ansi.SetUnderlining u              -> Style bold (isUnderline u) color
            Ansi.SetBlinkSpeed _               -> style
            Ansi.SetVisible _                  -> style
            Ansi.SetSwapForegroundBackground _ -> style
            Ansi.SetColor l i c                -> Style bold underline (toColor l i c)
            Ansi.SetRGBColor _ _               -> style
            _                                  -> error $ "sgrToStyle: unimplemented style: " ++ show sgr
  
  
  isBold :: Ansi.ConsoleIntensity -> Bool
  isBold intensity =
    case intensity of
      Ansi.BoldIntensity -> True
      Ansi.FaintIntensity -> False
      Ansi.NormalIntensity -> False
  
  
  isUnderline :: Ansi.Underlining -> Bool
  isUnderline underlining =
    case underlining of
      Ansi.SingleUnderline -> True
      Ansi.DoubleUnderline -> False
      Ansi.NoUnderline -> False
  
  
  toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color
  toColor layer intensity color =
    case layer of
      Ansi.Background ->
        Nothing
  
      Ansi.Foreground ->
        let
          pick dull vivid =
            case intensity of
              Ansi.Dull -> dull
              Ansi.Vivid -> vivid
        in
        Just $
          case color of
            Ansi.Red     -> pick Red     RED
            Ansi.Magenta -> pick Magenta MAGENTA
            Ansi.Yellow  -> pick Yellow  YELLOW
            Ansi.Green   -> pick Green   GREEN
            Ansi.Cyan    -> pick Cyan    CYAN
            Ansi.Blue    -> pick Blue    BLUE
            Ansi.White   -> pick White   WHITE
            Ansi.Black   -> pick Black   BLACK
  
  
  encodeChunks :: Style -> [String] -> E.Value
  encodeChunks (Style bold underline color) revChunks =
    let
      chars = concat (reverse revChunks)
    in
    case color of
      Nothing | not bold && not underline ->
        E.chars chars
  
      _ ->
        E.object
          [ "bold" ==> E.bool bold
          , "underline" ==> E.bool underline
          , "color" ==> maybe E.null encodeColor color
          , "string" ==> E.chars chars
          ]
  
  
  encodeColor :: Color -> E.Value
  encodeColor color =
    E.string $ Json.fromChars $
      case color of
        Red -> "red"
        RED -> "RED"
        Magenta -> "magenta"
        MAGENTA -> "MAGENTA"
        Yellow -> "yellow"
        YELLOW -> "YELLOW"
        Green -> "green"
        GREEN -> "GREEN"
        Cyan -> "cyan"
        CYAN -> "CYAN"
        Blue -> "blue"
        BLUE -> "BLUE"
        Black -> "black"
        BLACK -> "BLACK"
        White -> "white"
        WHITE -> "WHITE"
  