    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    {-|
    Module      : Text.Pretty.Simple.Internal.Printer
    Copyright   : (c) Dennis Gosnell, 2016
    License     : BSD-style (see LICENSE file)
    Maintainer  : cdep.illabout@gmail.com
    Stability   : experimental
    Portability : POSIX

    -}
    module Text.Pretty.Simple.Internal.Printer
      where

    -- We don't need these imports for later GHCs as all required functions
    -- are exported from Prelude
    #if __GLASGOW_HASKELL__ < 710
    import Control.Applicative
    #endif
    #if __GLASGOW_HASKELL__ < 804
    import Data.Monoid ((<>))
    #endif

    import Control.Monad.IO.Class (MonadIO, liftIO)
    import Control.Monad (join)
    import Control.Monad.State (MonadState, evalState, modify, gets)
    import Data.Char (isPrint, ord)
    import Data.List.NonEmpty (NonEmpty, nonEmpty)
    import Data.Maybe (fromMaybe)
    import Prettyprinter
      (indent, line', PageWidth(AvailablePerLine), layoutPageWidth, nest,
        concatWith, space, Doc, SimpleDocStream, annotate, defaultLayoutOptions,
        enclose, hcat, layoutSmart, line, unAnnotateS, pretty, group,
        removeTrailingWhitespace)
    import Data.Typeable (Typeable)
    import GHC.Generics (Generic)
    import Numeric (showHex)
    import System.IO (Handle, hIsTerminalDevice)
    import Text.Read (readMaybe)

    import Text.Pretty.Simple.Internal.Expr
      (Expr(..), CommaSeparated(CommaSeparated))
    import Text.Pretty.Simple.Internal.ExprParser (expressionParse)
    import Text.Pretty.Simple.Internal.Color
           (colorNull, Style, ColorOptions(..), defaultColorOptionsDarkBg,
            defaultColorOptionsLightBg)

    -- $setup
    -- >>> import Text.Pretty.Simple (pPrintString, pPrintStringOpt)

    -- | Determines whether pretty-simple should check if the output 'Handle' is a
    -- TTY device.  Normally, users only want to print in color if the output
    -- 'Handle' is a TTY device.
    data CheckColorTty
      = CheckColorTty
      -- ^ Check if the output 'Handle' is a TTY device.  If the output 'Handle' is
      -- a TTY device, determine whether to print in color based on
      -- 'outputOptionsColorOptions'. If not, then set 'outputOptionsColorOptions'
      -- to 'Nothing' so the output does not get colorized.
      | NoCheckColorTty
      -- ^ Don't check if the output 'Handle' is a TTY device.  Determine whether to
      -- colorize the output based solely on the value of
      -- 'outputOptionsColorOptions'.
      deriving (CheckColorTty -> CheckColorTty -> Bool
    (CheckColorTty -> CheckColorTty -> Bool)
    -> (CheckColorTty -> CheckColorTty -> Bool) -> Eq CheckColorTty
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: CheckColorTty -> CheckColorTty -> Bool
    == :: CheckColorTty -> CheckColorTty -> Bool
    $c/= :: CheckColorTty -> CheckColorTty -> Bool
    /= :: CheckColorTty -> CheckColorTty -> Bool
    Eq, (forall x. CheckColorTty -> Rep CheckColorTty x)
    -> (forall x. Rep CheckColorTty x -> CheckColorTty)
    -> Generic CheckColorTty
    forall x. Rep CheckColorTty x -> CheckColorTty
    forall x. CheckColorTty -> Rep CheckColorTty x
    forall a.
    (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
    $cfrom :: forall x. CheckColorTty -> Rep CheckColorTty x
    from :: forall x. CheckColorTty -> Rep CheckColorTty x
    $cto :: forall x. Rep CheckColorTty x -> CheckColorTty
    to :: forall x. Rep CheckColorTty x -> CheckColorTty
    Generic, Int -> CheckColorTty -> ShowS
    [CheckColorTty] -> ShowS
    CheckColorTty -> String
    (Int -> CheckColorTty -> ShowS)
    -> (CheckColorTty -> String)
    -> ([CheckColorTty] -> ShowS)
    -> Show CheckColorTty
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> CheckColorTty -> ShowS
    showsPrec :: Int -> CheckColorTty -> ShowS
    $cshow :: CheckColorTty -> String
    show :: CheckColorTty -> String
    $cshowList :: [CheckColorTty] -> ShowS
    showList :: [CheckColorTty] -> ShowS
    Show, Typeable)

    -- | Control how escaped and non-printable are output for strings.
    --
    -- See 'outputOptionsStringStyle' for what the output looks like with each of
    -- these options.
    data StringOutputStyle
      = Literal
      -- ^ Output string literals by printing the source characters exactly.
      --
      -- For examples: without this option the printer will insert a newline in
      -- place of @"\n"@, with this options the printer will output @'\'@ and
      -- @'n'@. Similarly the exact escape codes used in the input string will be
      -- replicated, so @"\65"@ will be printed as @"\65"@ and not @"A"@.
      | EscapeNonPrintable
      -- ^ Replace non-printable characters with hexadecimal escape sequences.
      | DoNotEscapeNonPrintable
      -- ^ Output non-printable characters without modification.
      deriving (StringOutputStyle -> StringOutputStyle -> Bool
    (StringOutputStyle -> StringOutputStyle -> Bool)
    -> (StringOutputStyle -> StringOutputStyle -> Bool)
    -> Eq StringOutputStyle
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: StringOutputStyle -> StringOutputStyle -> Bool
    == :: StringOutputStyle -> StringOutputStyle -> Bool
    $c/= :: StringOutputStyle -> StringOutputStyle -> Bool
    /= :: StringOutputStyle -> StringOutputStyle -> Bool
    Eq, (forall x. StringOutputStyle -> Rep StringOutputStyle x)
    -> (forall x. Rep StringOutputStyle x -> StringOutputStyle)
    -> Generic StringOutputStyle
    forall x. Rep StringOutputStyle x -> StringOutputStyle
    forall x. StringOutputStyle -> Rep StringOutputStyle x
    forall a.
    (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
    $cfrom :: forall x. StringOutputStyle -> Rep StringOutputStyle x
    from :: forall x. StringOutputStyle -> Rep StringOutputStyle x
    $cto :: forall x. Rep StringOutputStyle x -> StringOutputStyle
    to :: forall x. Rep StringOutputStyle x -> StringOutputStyle
    Generic, Int -> StringOutputStyle -> ShowS
    [StringOutputStyle] -> ShowS
    StringOutputStyle -> String
    (Int -> StringOutputStyle -> ShowS)
    -> (StringOutputStyle -> String)
    -> ([StringOutputStyle] -> ShowS)
    -> Show StringOutputStyle
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> StringOutputStyle -> ShowS
    showsPrec :: Int -> StringOutputStyle -> ShowS
    $cshow :: StringOutputStyle -> String
    show :: StringOutputStyle -> String
    $cshowList :: [StringOutputStyle] -> ShowS
    showList :: [StringOutputStyle] -> ShowS
    Show, Typeable)

    -- | Data-type wrapping up all the options available when rendering the list
    -- of 'Output's.
    data OutputOptions = OutputOptions
      { OutputOptions -> Int
    outputOptionsIndentAmount :: Int
      -- ^ Number of spaces to use when indenting.  It should probably be either 2
      -- or 4.
      , OutputOptions -> Int
    outputOptionsPageWidth :: Int
      -- ^ The maximum number of characters to fit on to one line.
      , OutputOptions -> Bool
    outputOptionsCompact :: Bool
      -- ^ Use less vertical (and more horizontal) space.
      , OutputOptions -> Bool
    outputOptionsCompactParens :: Bool
      -- ^ Group closing parentheses on to a single line.
      , OutputOptions -> Int
    outputOptionsInitialIndent :: Int
      -- ^ Indent the whole output by this amount.
      , OutputOptions -> Maybe ColorOptions
    outputOptionsColorOptions :: Maybe ColorOptions
      -- ^ If this is 'Nothing', then don't colorize the output.  If this is
      -- @'Just' colorOptions@, then use @colorOptions@ to colorize the output.
      --
      , OutputOptions -> StringOutputStyle
    outputOptionsStringStyle :: StringOutputStyle
      -- ^ Controls how string literals are output.
      --
      -- By default, the pPrint functions escape non-printable characters, but
      -- print all printable characters:
      --
      -- >>> pPrintString "\"A \\x42 Ä \\xC4 \\x1 \\n\""
      -- "A B Ä Ä \x1
      -- "
      --
      -- Here, you can see that the character @A@ has been printed as-is.  @\x42@
      -- has been printed in the non-escaped version, @B@.  The non-printable
      -- character @\x1@ has been printed as @\x1@.  Newlines will be removed to
      -- make the output easier to read.
      --
      -- This corresponds to the 'StringOutputStyle' called 'EscapeNonPrintable'.
      --
      -- (Note that in the above and following examples, the characters have to be
      -- double-escaped, which makes it somewhat confusing...)
      --
      -- Another output style is 'DoNotEscapeNonPrintable'.  This is similar
      -- to 'EscapeNonPrintable', except that non-printable characters get printed
      -- out literally to the screen.
      --
      -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = DoNotEscapeNonPrintable } "\"A \\x42 Ä \\xC4 \\n\""
      -- "A B Ä Ä
      -- "
      --
      -- If you change the above example to contain @\x1@, you can see that it is
      -- output as a literal, non-escaped character.  Newlines are still removed
      -- for readability.
      --
      -- Another output style is 'Literal'.  This just outputs all escape characters.
      --
      -- >>> pPrintStringOpt CheckColorTty defaultOutputOptionsDarkBg{ outputOptionsStringStyle = Literal } "\"A \\x42 Ä \\xC4 \\x1 \\n\""
      -- "A \x42 Ä \xC4 \x1 \n"
      --
      -- You can see that all the escape characters get output literally, including
      -- newline.
      } deriving (OutputOptions -> OutputOptions -> Bool
    (OutputOptions -> OutputOptions -> Bool)
    -> (OutputOptions -> OutputOptions -> Bool) -> Eq OutputOptions
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: OutputOptions -> OutputOptions -> Bool
    == :: OutputOptions -> OutputOptions -> Bool
    $c/= :: OutputOptions -> OutputOptions -> Bool
    /= :: OutputOptions -> OutputOptions -> Bool
    Eq, (forall x. OutputOptions -> Rep OutputOptions x)
    -> (forall x. Rep OutputOptions x -> OutputOptions)
    -> Generic OutputOptions
    forall x. Rep OutputOptions x -> OutputOptions
    forall x. OutputOptions -> Rep OutputOptions x
    forall a.
    (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
    $cfrom :: forall x. OutputOptions -> Rep OutputOptions x
    from :: forall x. OutputOptions -> Rep OutputOptions x
    $cto :: forall x. Rep OutputOptions x -> OutputOptions
    to :: forall x. Rep OutputOptions x -> OutputOptions
    Generic, Int -> OutputOptions -> ShowS
    [OutputOptions] -> ShowS
    OutputOptions -> String
    (Int -> OutputOptions -> ShowS)
    -> (OutputOptions -> String)
    -> ([OutputOptions] -> ShowS)
    -> Show OutputOptions
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> OutputOptions -> ShowS
    showsPrec :: Int -> OutputOptions -> ShowS
    $cshow :: OutputOptions -> String
    show :: OutputOptions -> String
    $cshowList :: [OutputOptions] -> ShowS
    showList :: [OutputOptions] -> ShowS
    Show, Typeable)

    -- | Default values for 'OutputOptions' when printing to a console with a dark
    -- background.  'outputOptionsIndentAmount' is 4, and
    -- 'outputOptionsColorOptions' is 'defaultColorOptionsDarkBg'.
    defaultOutputOptionsDarkBg :: OutputOptions
    defaultOutputOptionsDarkBg :: OutputOptions
    defaultOutputOptionsDarkBg =
      OutputOptions
    defaultOutputOptionsNoColor
      { outputOptionsColorOptions = Just defaultColorOptionsDarkBg }

    -- | Default values for 'OutputOptions' when printing to a console with a light
    -- background.  'outputOptionsIndentAmount' is 4, and
    -- 'outputOptionsColorOptions' is 'defaultColorOptionsLightBg'.
    defaultOutputOptionsLightBg :: OutputOptions
    defaultOutputOptionsLightBg :: OutputOptions
    defaultOutputOptionsLightBg =
      OutputOptions
    defaultOutputOptionsNoColor
      { outputOptionsColorOptions = Just defaultColorOptionsLightBg }

    -- | Default values for 'OutputOptions' when printing using using ANSI escape
    -- sequences for color.  'outputOptionsIndentAmount' is 4, and
    -- 'outputOptionsColorOptions' is 'Nothing'.
    defaultOutputOptionsNoColor :: OutputOptions
    defaultOutputOptionsNoColor :: OutputOptions
    defaultOutputOptionsNoColor =
      OutputOptions
      { outputOptionsIndentAmount :: Int
    outputOptionsIndentAmount = Int
    4
      , outputOptionsPageWidth :: Int
    outputOptionsPageWidth = Int
    80
      , outputOptionsCompact :: Bool
    outputOptionsCompact = Bool
    False
      , outputOptionsCompactParens :: Bool
    outputOptionsCompactParens = Bool
    False
      , outputOptionsInitialIndent :: Int
    outputOptionsInitialIndent = Int
    0
      , outputOptionsColorOptions :: Maybe ColorOptions
    outputOptionsColorOptions = Maybe ColorOptions
    forall a. Maybe a
    Nothing
      , outputOptionsStringStyle :: StringOutputStyle
    outputOptionsStringStyle = StringOutputStyle
    EscapeNonPrintable
      }

    -- | Given 'OutputOptions', disable colorful output if the given handle
    -- is not connected to a TTY.
    hCheckTTY :: MonadIO m => Handle -> OutputOptions -> m OutputOptions
    hCheckTTY :: forall (m :: * -> *).
    MonadIO m =>
    Handle -> OutputOptions -> m OutputOptions
    hCheckTTY Handle
    h OutputOptions
    options = IO OutputOptions -> m OutputOptions
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO OutputOptions -> m OutputOptions)
    -> IO OutputOptions -> m OutputOptions
    forall a b. (a -> b) -> a -> b
    $ Bool -> OutputOptions
    conv (Bool -> OutputOptions) -> IO Bool -> IO OutputOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO Bool
    tty
      where
        conv :: Bool -> OutputOptions
        conv :: Bool -> OutputOptions
    conv Bool
    True = OutputOptions
    options
        conv Bool
    False = OutputOptions
    options { outputOptionsColorOptions = Nothing }

        tty :: IO Bool
        tty :: IO Bool
    tty = Handle -> IO Bool
    hIsTerminalDevice Handle
    h

    -- | Parse a string, and generate an intermediate representation,
    -- suitable for passing to any /prettyprinter/ backend.
    -- Used by 'Simple.pString' etc.
    layoutString :: OutputOptions -> String -> SimpleDocStream Style
    layoutString :: OutputOptions -> String -> SimpleDocStream Style
    layoutString OutputOptions
    opts = OutputOptions
    -> SimpleDocStream Annotation -> SimpleDocStream Style
    annotateStyle OutputOptions
    opts (SimpleDocStream Annotation -> SimpleDocStream Style)
    -> (String -> SimpleDocStream Annotation)
    -> String
    -> SimpleDocStream Style
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OutputOptions -> String -> SimpleDocStream Annotation
    layoutStringAbstract OutputOptions
    opts

    layoutStringAbstract :: OutputOptions -> String -> SimpleDocStream Annotation
    layoutStringAbstract :: OutputOptions -> String -> SimpleDocStream Annotation
    layoutStringAbstract OutputOptions
    opts =
        SimpleDocStream Annotation -> SimpleDocStream Annotation
    forall ann. SimpleDocStream ann -> SimpleDocStream ann
    removeTrailingWhitespace
        (SimpleDocStream Annotation -> SimpleDocStream Annotation)
    -> (String -> SimpleDocStream Annotation)
    -> String
    -> SimpleDocStream Annotation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LayoutOptions -> Doc Annotation -> SimpleDocStream Annotation
    forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
    layoutSmart LayoutOptions
    defaultLayoutOptions
          {layoutPageWidth = AvailablePerLine (outputOptionsPageWidth opts) 1}
        (Doc Annotation -> SimpleDocStream Annotation)
    -> (String -> Doc Annotation)
    -> String
    -> SimpleDocStream Annotation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Doc Annotation -> Doc Annotation
    forall ann. Int -> Doc ann -> Doc ann
    indent (OutputOptions -> Int
    outputOptionsInitialIndent OutputOptions
    opts)
        (Doc Annotation -> Doc Annotation)
    -> (String -> Doc Annotation) -> String -> Doc Annotation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs' OutputOptions
    opts
        ([Expr] -> Doc Annotation)
    -> (String -> [Expr]) -> String -> Doc Annotation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [Expr]
    expressionParse

    -- | Slight adjustment of 'prettyExprs' for the outermost level,
    -- to avoid indenting everything.
    prettyExprs' :: OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs' :: OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs' OutputOptions
    opts = \case
      [] -> Doc Annotation
    forall a. Monoid a => a
    mempty
      Expr
    x : [Expr]
    xs -> OutputOptions -> Expr -> Doc Annotation
    prettyExpr OutputOptions
    opts Expr
    x Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs OutputOptions
    opts [Expr]
    xs

    -- | Construct a 'Doc' from multiple 'Expr's.
    prettyExprs :: OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs :: OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs OutputOptions
    opts = [Doc Annotation] -> Doc Annotation
    forall ann. [Doc ann] -> Doc ann
    hcat ([Doc Annotation] -> Doc Annotation)
    -> ([Expr] -> [Doc Annotation]) -> [Expr] -> Doc Annotation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Expr -> Doc Annotation) -> [Expr] -> [Doc Annotation]
    forall a b. (a -> b) -> [a] -> [b]
    map Expr -> Doc Annotation
    subExpr
      where
        subExpr :: Expr -> Doc Annotation
    subExpr Expr
    x =
          let doc :: Doc Annotation
    doc = OutputOptions -> Expr -> Doc Annotation
    prettyExpr OutputOptions
    opts Expr
    x
          in
            if Expr -> Bool
    isSimple Expr
    x then
              -- keep the expression on the current line
              Int -> Doc Annotation -> Doc Annotation
    forall ann. Int -> Doc ann -> Doc ann
    nest Int
    2 Doc Annotation
    doc
            else
              -- put the expression on a new line, indented (unless grouped)
              Int -> Doc Annotation -> Doc Annotation
    forall ann. Int -> Doc ann -> Doc ann
    nest (OutputOptions -> Int
    outputOptionsIndentAmount OutputOptions
    opts) (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ Doc Annotation
    forall ann. Doc ann
    line' Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> Doc Annotation
    doc

    -- | Construct a 'Doc' from a single 'Expr'.
    prettyExpr :: OutputOptions -> Expr -> Doc Annotation
    prettyExpr :: OutputOptions -> Expr -> Doc Annotation
    prettyExpr OutputOptions
    opts = (if OutputOptions -> Bool
    outputOptionsCompact OutputOptions
    opts then Doc Annotation -> Doc Annotation
    forall ann. Doc ann -> Doc ann
    group else Doc Annotation -> Doc Annotation
    forall a. a -> a
    id) (Doc Annotation -> Doc Annotation)
    -> (Expr -> Doc Annotation) -> Expr -> Doc Annotation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . \case
      Brackets CommaSeparated [Expr]
    xss -> Doc Annotation
    -> Doc Annotation -> CommaSeparated [Expr] -> Doc Annotation
    list Doc Annotation
    "[" Doc Annotation
    "]" CommaSeparated [Expr]
    xss
      Braces CommaSeparated [Expr]
    xss -> Doc Annotation
    -> Doc Annotation -> CommaSeparated [Expr] -> Doc Annotation
    list Doc Annotation
    "{" Doc Annotation
    "}" CommaSeparated [Expr]
    xss
      Parens CommaSeparated [Expr]
    xss -> Doc Annotation
    -> Doc Annotation -> CommaSeparated [Expr] -> Doc Annotation
    list Doc Annotation
    "(" Doc Annotation
    ")" CommaSeparated [Expr]
    xss
      StringLit String
    s -> (Doc Annotation
     -> Doc Annotation -> Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation -> Doc Annotation
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join Doc Annotation
    -> Doc Annotation -> Doc Annotation -> Doc Annotation
    forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
    enclose (Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    Quote Doc Annotation
    "\"") (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    String (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ String -> Doc Annotation
    forall ann. String -> Doc ann
    forall a ann. Pretty a => a -> Doc ann
    pretty (String -> Doc Annotation) -> String -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $
        case OutputOptions -> StringOutputStyle
    outputOptionsStringStyle OutputOptions
    opts of
          StringOutputStyle
    Literal -> String
    s
          StringOutputStyle
    EscapeNonPrintable -> ShowS
    escapeNonPrintable ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ ShowS
    readStr String
    s
          StringOutputStyle
    DoNotEscapeNonPrintable -> ShowS
    readStr String
    s
      CharLit String
    s -> (Doc Annotation
     -> Doc Annotation -> Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation -> Doc Annotation
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join Doc Annotation
    -> Doc Annotation -> Doc Annotation -> Doc Annotation
    forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
    enclose (Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    Quote Doc Annotation
    "'") (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    String (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ String -> Doc Annotation
    forall ann. String -> Doc ann
    forall a ann. Pretty a => a -> Doc ann
    pretty String
    s
      Other String
    s -> String -> Doc Annotation
    forall ann. String -> Doc ann
    forall a ann. Pretty a => a -> Doc ann
    pretty String
    s
      NumberLit String
    n -> Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    Num (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ String -> Doc Annotation
    forall ann. String -> Doc ann
    forall a ann. Pretty a => a -> Doc ann
    pretty String
    n
      where
        readStr :: String -> String
        readStr :: ShowS
    readStr String
    s = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    s (Maybe String -> String) -> (String -> Maybe String) -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Maybe String
    forall a. Read a => String -> Maybe a
    readMaybe ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ Char
    '"' Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    s String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "\""
        list :: Doc Annotation -> Doc Annotation -> CommaSeparated [Expr]
          -> Doc Annotation
        list :: Doc Annotation
    -> Doc Annotation -> CommaSeparated [Expr] -> Doc Annotation
    list Doc Annotation
    open Doc Annotation
    close (CommaSeparated [[Expr]]
    xss) =
          Doc Annotation
    -> Doc Annotation -> Doc Annotation -> Doc Annotation
    forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
    enclose (Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    Open Doc Annotation
    open) (Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    Close Doc Annotation
    close) (Doc Annotation -> Doc Annotation)
    -> Doc Annotation -> Doc Annotation
    forall a b. (a -> b) -> a -> b
    $ case [[Expr]]
    xss of
            [] -> Doc Annotation
    forall a. Monoid a => a
    mempty
            [[Expr]
    xs] | (Expr -> Bool) -> [Expr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Expr -> Bool
    isSimple [Expr]
    xs ->
              Doc Annotation
    forall ann. Doc ann
    space Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> [Doc Annotation] -> Doc Annotation
    forall ann. [Doc ann] -> Doc ann
    hcat ((Expr -> Doc Annotation) -> [Expr] -> [Doc Annotation]
    forall a b. (a -> b) -> [a] -> [b]
    map (OutputOptions -> Expr -> Doc Annotation
    prettyExpr OutputOptions
    opts) [Expr]
    xs) Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> Doc Annotation
    forall ann. Doc ann
    space
            [[Expr]]
    _ -> (Doc Annotation -> Doc Annotation -> Doc Annotation)
    -> [Doc Annotation] -> Doc Annotation
    forall (t :: * -> *) ann.
    Foldable t =>
    (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
    concatWith Doc Annotation -> Doc Annotation -> Doc Annotation
    lineAndCommaSep (([Expr] -> Doc Annotation) -> [[Expr]] -> [Doc Annotation]
    forall a b. (a -> b) -> [a] -> [b]
    map (\[Expr]
    xs -> [Expr] -> Doc Annotation
    forall {ann}. [Expr] -> Doc ann
    spaceIfNeeded [Expr]
    xs Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> OutputOptions -> [Expr] -> Doc Annotation
    prettyExprs OutputOptions
    opts [Expr]
    xs) [[Expr]]
    xss)
              Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> if OutputOptions -> Bool
    outputOptionsCompactParens OutputOptions
    opts then Doc Annotation
    forall ann. Doc ann
    space else Doc Annotation
    forall ann. Doc ann
    line
              where
                spaceIfNeeded :: [Expr] -> Doc ann
    spaceIfNeeded = \case
                  Other (Char
    ' ' : String
    _) : [Expr]
    _ -> Doc ann
    forall a. Monoid a => a
    mempty
                  [Expr]
    _ -> Doc ann
    forall ann. Doc ann
    space
        lineAndCommaSep :: Doc Annotation -> Doc Annotation -> Doc Annotation
    lineAndCommaSep Doc Annotation
    x Doc Annotation
    y = Doc Annotation
    x Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> Bool -> Doc Annotation -> Doc Annotation
    forall {a}. Monoid a => Bool -> a -> a
    munless (OutputOptions -> Bool
    outputOptionsCompact OutputOptions
    opts) Doc Annotation
    forall ann. Doc ann
    line' Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> Annotation -> Doc Annotation -> Doc Annotation
    forall ann. ann -> Doc ann -> Doc ann
    annotate Annotation
    Comma Doc Annotation
    "," Doc Annotation -> Doc Annotation -> Doc Annotation
    forall a. Semigroup a => a -> a -> a
    <> Doc Annotation
    y
        munless :: Bool -> a -> a
    munless Bool
    b a
    x = if Bool
    b then a
    forall a. Monoid a => a
    mempty else a
    x

    -- | Determine whether this expression should be displayed on a single line.
    isSimple :: Expr -> Bool
    isSimple :: Expr -> Bool
    isSimple = \case
      Brackets (CommaSeparated [[Expr]]
    xs) -> [[Expr]] -> Bool
    isListSimple [[Expr]]
    xs
      Braces (CommaSeparated [[Expr]]
    xs) -> [[Expr]] -> Bool
    isListSimple [[Expr]]
    xs
      Parens (CommaSeparated [[Expr]]
    xs) -> [[Expr]] -> Bool
    isListSimple [[Expr]]
    xs
      Expr
    _ -> Bool
    True
      where
        isListSimple :: [[Expr]] -> Bool
    isListSimple = \case
          [[Expr
    e]] -> Expr -> Bool
    isSimple Expr
    e
          [Expr]
    _:[[Expr]]
    _ -> Bool
    False
          [] -> Bool
    True

    -- | Traverse the stream, using a 'Tape' to keep track of the current style.
    annotateStyle :: OutputOptions -> SimpleDocStream Annotation
      -> SimpleDocStream Style
    annotateStyle :: OutputOptions
    -> SimpleDocStream Annotation -> SimpleDocStream Style
    annotateStyle OutputOptions
    opts SimpleDocStream Annotation
    ds = case OutputOptions -> Maybe ColorOptions
    outputOptionsColorOptions OutputOptions
    opts of
      Maybe ColorOptions
    Nothing -> SimpleDocStream Annotation -> SimpleDocStream Style
    forall ann xxx. SimpleDocStream ann -> SimpleDocStream xxx
    unAnnotateS SimpleDocStream Annotation
    ds
      Just ColorOptions {[Style]
    Style
    colorQuote :: Style
    colorString :: Style
    colorError :: Style
    colorNum :: Style
    colorRainbowParens :: [Style]
    colorQuote :: ColorOptions -> Style
    colorString :: ColorOptions -> Style
    colorError :: ColorOptions -> Style
    colorNum :: ColorOptions -> Style
    colorRainbowParens :: ColorOptions -> [Style]
    ..} -> State (Tape Style) (SimpleDocStream Style)
    -> Tape Style -> SimpleDocStream Style
    forall s a. State s a -> s -> a
    evalState ((Annotation -> StateT (Tape Style) Identity Style)
    -> SimpleDocStream Annotation
    -> State (Tape Style) (SimpleDocStream Style)
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> SimpleDocStream a -> f (SimpleDocStream b)
    traverse Annotation -> StateT (Tape Style) Identity Style
    forall (m :: * -> *).
    MonadState (Tape Style) m =>
    Annotation -> m Style
    style SimpleDocStream Annotation
    ds) Tape Style
    initialTape
        where
          style :: MonadState (Tape Style) m => Annotation -> m Style
          style :: forall (m :: * -> *).
    MonadState (Tape Style) m =>
    Annotation -> m Style
    style = \case
            Annotation
    Open -> (Tape Style -> Tape Style) -> m ()
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
    modify Tape Style -> Tape Style
    forall a. Tape a -> Tape a
    moveR m () -> m Style -> m Style
    forall a b. m a -> m b -> m b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> (Tape Style -> Style) -> m Style
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets Tape Style -> Style
    forall a. Tape a -> a
    tapeHead
            Annotation
    Close -> (Tape Style -> Style) -> m Style
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets Tape Style -> Style
    forall a. Tape a -> a
    tapeHead m Style -> m () -> m Style
    forall a b. m a -> m b -> m a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* (Tape Style -> Tape Style) -> m ()
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
    modify Tape Style -> Tape Style
    forall a. Tape a -> Tape a
    moveL
            Annotation
    Comma -> (Tape Style -> Style) -> m Style
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets Tape Style -> Style
    forall a. Tape a -> a
    tapeHead
            Annotation
    Quote -> Style -> m Style
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Style
    colorQuote
            Annotation
    String -> Style -> m Style
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Style
    colorString
            Annotation
    Num -> Style -> m Style
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Style
    colorNum
          initialTape :: Tape Style
    initialTape = Tape
            { tapeLeft :: Stream Style
    tapeLeft = Style -> Stream Style
    forall t. t -> Stream t
    streamRepeat Style
    colorError
            , tapeHead :: Style
    tapeHead = Style
    colorError
            , tapeRight :: Stream Style
    tapeRight = NonEmpty Style -> Stream Style
    forall a. NonEmpty a -> Stream a
    streamCycle (NonEmpty Style -> Stream Style) -> NonEmpty Style -> Stream Style
    forall a b. (a -> b) -> a -> b
    $ NonEmpty Style -> Maybe (NonEmpty Style) -> NonEmpty Style
    forall a. a -> Maybe a -> a
    fromMaybe (Style -> NonEmpty Style
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Style
    colorNull)
                (Maybe (NonEmpty Style) -> NonEmpty Style)
    -> Maybe (NonEmpty Style) -> NonEmpty Style
    forall a b. (a -> b) -> a -> b
    $ [Style] -> Maybe (NonEmpty Style)
    forall a. [a] -> Maybe (NonEmpty a)
    nonEmpty [Style]
    colorRainbowParens
            }

    -- | An abstract annotation type, representing the various elements
    -- we may want to highlight.
    data Annotation
      = Open
      | Close
      | Comma
      | Quote
      | String
      | Num
      deriving (Annotation -> Annotation -> Bool
    (Annotation -> Annotation -> Bool)
    -> (Annotation -> Annotation -> Bool) -> Eq Annotation
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Annotation -> Annotation -> Bool
    == :: Annotation -> Annotation -> Bool
    $c/= :: Annotation -> Annotation -> Bool
    /= :: Annotation -> Annotation -> Bool
    Eq, Int -> Annotation -> ShowS
    [Annotation] -> ShowS
    Annotation -> String
    (Int -> Annotation -> ShowS)
    -> (Annotation -> String)
    -> ([Annotation] -> ShowS)
    -> Show Annotation
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Annotation -> ShowS
    showsPrec :: Int -> Annotation -> ShowS
    $cshow :: Annotation -> String
    show :: Annotation -> String
    $cshowList :: [Annotation] -> ShowS
    showList :: [Annotation] -> ShowS
    Show)

    -- | Replace non-printable characters with hex escape sequences.
    --
    -- >>> escapeNonPrintable "\x1\x2"
    -- "\\x1\\x2"
    --
    -- Newlines will not be escaped.
    --
    -- >>> escapeNonPrintable "hello\nworld"
    -- "hello\nworld"
    --
    -- Printable characters will not be escaped.
    --
    -- >>> escapeNonPrintable "h\101llo"
    -- "hello"
    escapeNonPrintable :: String -> String
    escapeNonPrintable :: ShowS
    escapeNonPrintable = (Char -> ShowS) -> String -> ShowS
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Char -> ShowS
    escape String
    ""

    -- | Replace an unprintable character except a newline
    -- with a hex escape sequence.
    escape :: Char -> ShowS
    escape :: Char -> ShowS
    escape Char
    c
      | Char -> Bool
    isPrint Char
    c Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n' = (Char
    cChar -> ShowS
    forall a. a -> [a] -> [a]
    :)
      | Bool
    otherwise = (Char
    '\\'Char -> ShowS
    forall a. a -> [a] -> [a]
    :) ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    'x'Char -> ShowS
    forall a. a -> [a] -> [a]
    :) ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> ShowS
    forall a. Integral a => a -> ShowS
    showHex (Char -> Int
    ord Char
    c)

    -- | A bidirectional Turing-machine tape:
    -- infinite in both directions, with a head pointing to one element.
    data Tape a = Tape
      { forall a. Tape a -> Stream a
    tapeLeft  :: Stream a -- ^ the side of the 'Tape' left of 'tapeHead'
      , forall a. Tape a -> a
    tapeHead  :: a        -- ^ the focused element
      , forall a. Tape a -> Stream a
    tapeRight :: Stream a -- ^ the side of the 'Tape' right of 'tapeHead'
      } deriving Int -> Tape a -> ShowS
    [Tape a] -> ShowS
    Tape a -> String
    (Int -> Tape a -> ShowS)
    -> (Tape a -> String) -> ([Tape a] -> ShowS) -> Show (Tape a)
    forall a. Show a => Int -> Tape a -> ShowS
    forall a. Show a => [Tape a] -> ShowS
    forall a. Show a => Tape a -> String
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: forall a. Show a => Int -> Tape a -> ShowS
    showsPrec :: Int -> Tape a -> ShowS
    $cshow :: forall a. Show a => Tape a -> String
    show :: Tape a -> String
    $cshowList :: forall a. Show a => [Tape a] -> ShowS
    showList :: [Tape a] -> ShowS
    Show
    -- | Move the head left
    moveL :: Tape a -> Tape a
    moveL :: forall a. Tape a -> Tape a
    moveL (Tape (a
    l :.. Stream a
    ls) a
    c Stream a
    rs) = Stream a -> a -> Stream a -> Tape a
    forall a. Stream a -> a -> Stream a -> Tape a
    Tape Stream a
    ls a
    l (a
    c a -> Stream a -> Stream a
    forall a. a -> Stream a -> Stream a
    :.. Stream a
    rs)
    -- | Move the head right
    moveR :: Tape a -> Tape a
    moveR :: forall a. Tape a -> Tape a
    moveR (Tape Stream a
    ls a
    c (a
    r :.. Stream a
    rs)) = Stream a -> a -> Stream a -> Tape a
    forall a. Stream a -> a -> Stream a -> Tape a
    Tape (a
    c a -> Stream a -> Stream a
    forall a. a -> Stream a -> Stream a
    :.. Stream a
    ls) a
    r Stream a
    rs

    -- | An infinite list
    data Stream a = a :.. Stream a deriving Int -> Stream a -> ShowS
    [Stream a] -> ShowS
    Stream a -> String
    (Int -> Stream a -> ShowS)
    -> (Stream a -> String) -> ([Stream a] -> ShowS) -> Show (Stream a)
    forall a. Show a => Int -> Stream a -> ShowS
    forall a. Show a => [Stream a] -> ShowS
    forall a. Show a => Stream a -> String
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: forall a. Show a => Int -> Stream a -> ShowS
    showsPrec :: Int -> Stream a -> ShowS
    $cshow :: forall a. Show a => Stream a -> String
    show :: Stream a -> String
    $cshowList :: forall a. Show a => [Stream a] -> ShowS
    showList :: [Stream a] -> ShowS
    Show
    -- | Analogous to 'repeat'
    streamRepeat :: t -> Stream t
    streamRepeat :: forall t. t -> Stream t
    streamRepeat t
    x = t
    x t -> Stream t -> Stream t
    forall a. a -> Stream a -> Stream a
    :.. t -> Stream t
    forall t. t -> Stream t
    streamRepeat t
    x
    -- | Analogous to 'cycle'
    -- While the inferred signature here is more general,
    -- it would diverge on an empty structure
    streamCycle :: NonEmpty a -> Stream a
    streamCycle :: forall a. NonEmpty a -> Stream a
    streamCycle NonEmpty a
    xs = (a -> Stream a -> Stream a) -> Stream a -> NonEmpty a -> Stream a
    forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr a -> Stream a -> Stream a
    forall a. a -> Stream a -> Stream a
    (:..) (NonEmpty a -> Stream a
    forall a. NonEmpty a -> Stream a
    streamCycle NonEmpty a
    xs) NonEmpty a
    xs