{-# 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
/= :: CheckColorTty -> CheckColorTty -> Bool
$c/= :: CheckColorTty -> CheckColorTty -> Bool
== :: CheckColorTty -> CheckColorTty -> Bool
$c== :: 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
$cto :: forall x. Rep CheckColorTty x -> CheckColorTty
$cfrom :: forall x. CheckColorTty -> Rep CheckColorTty x
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
showList :: [CheckColorTty] -> ShowS
$cshowList :: [CheckColorTty] -> ShowS
show :: CheckColorTty -> String
$cshow :: CheckColorTty -> String
showsPrec :: Int -> CheckColorTty -> ShowS
$cshowsPrec :: Int -> 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
/= :: StringOutputStyle -> StringOutputStyle -> Bool
$c/= :: StringOutputStyle -> StringOutputStyle -> Bool
== :: StringOutputStyle -> StringOutputStyle -> Bool
$c== :: 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
$cto :: forall x. Rep StringOutputStyle x -> StringOutputStyle
$cfrom :: forall x. StringOutputStyle -> Rep StringOutputStyle x
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
showList :: [StringOutputStyle] -> ShowS
$cshowList :: [StringOutputStyle] -> ShowS
show :: StringOutputStyle -> String
$cshow :: StringOutputStyle -> String
showsPrec :: Int -> StringOutputStyle -> ShowS
$cshowsPrec :: Int -> 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
/= :: OutputOptions -> OutputOptions -> Bool
$c/= :: OutputOptions -> OutputOptions -> Bool
== :: OutputOptions -> OutputOptions -> Bool
$c== :: 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
$cto :: forall x. Rep OutputOptions x -> OutputOptions
$cfrom :: forall x. OutputOptions -> Rep OutputOptions x
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
showList :: [OutputOptions] -> ShowS
$cshowList :: [OutputOptions] -> ShowS
show :: OutputOptions -> String
$cshow :: OutputOptions -> String
showsPrec :: Int -> OutputOptions -> ShowS
$cshowsPrec :: Int -> 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 :: Maybe ColorOptions
outputOptionsColorOptions = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions
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 :: Maybe ColorOptions
outputOptionsColorOptions = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions
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 :: Int
-> Int
-> Bool
-> Bool
-> Int
-> Maybe ColorOptions
-> StringOutputStyle
-> OutputOptions
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 :: Handle -> OutputOptions -> m OutputOptions
hCheckTTY Handle
h OutputOptions
options = IO OutputOptions -> m OutputOptions
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 :: Maybe ColorOptions
outputOptionsColorOptions = Maybe ColorOptions
forall a. Maybe a
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
. 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 :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine (OutputOptions -> Int
outputOptionsPageWidth OutputOptions
opts) Double
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 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 a ann. Pretty a => a -> Doc ann
pretty String
s
  Other String
s -> String -> Doc Annotation
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 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 p. Monoid p => Bool -> p -> p
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 -> p -> p
munless Bool
b p
x = if Bool
b then p
forall a. Monoid a => a
mempty else p
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
colorRainbowParens :: ColorOptions -> [Style]
colorNum :: ColorOptions -> Style
colorError :: ColorOptions -> Style
colorString :: ColorOptions -> Style
colorQuote :: ColorOptions -> Style
colorRainbowParens :: [Style]
colorNum :: Style
colorError :: Style
colorString :: Style
colorQuote :: 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)
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 :: 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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorQuote
        Annotation
String -> Style -> m Style
forall (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorString
        Annotation
Num -> Style -> m Style
forall (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorNum
      initialTape :: Tape Style
initialTape = Tape :: forall a. Stream a -> a -> Stream a -> Tape a
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 (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

-- | 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 (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, Show 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
  { Tape a -> Stream a
tapeLeft  :: Stream a -- ^ the side of the 'Tape' left of 'tapeHead'
  , Tape a -> a
tapeHead  :: a        -- ^ the focused element
  , 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
showList :: [Tape a] -> ShowS
$cshowList :: forall a. Show a => [Tape a] -> ShowS
show :: Tape a -> String
$cshow :: forall a. Show a => Tape a -> String
showsPrec :: Int -> Tape a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Tape a -> ShowS
Show
-- | Move the head left
moveL :: Tape a -> Tape a
moveL :: 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 :: 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
showList :: [Stream a] -> ShowS
$cshowList :: forall a. Show a => [Stream a] -> ShowS
show :: Stream a -> String
$cshow :: forall a. Show a => Stream a -> String
showsPrec :: Int -> Stream a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Stream a -> ShowS
Show
-- | Analogous to 'repeat'
streamRepeat :: t -> Stream t
streamRepeat :: 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 :: NonEmpty a -> Stream a
streamCycle NonEmpty a
xs = (a -> Stream a -> Stream a) -> Stream a -> NonEmpty a -> Stream a
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