{-# 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
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. 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
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
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. 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
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
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. 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
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 = 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 = 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
  { 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 = 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> OutputOptions
conv 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 = 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 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 =
    forall ann. SimpleDocStream ann -> SimpleDocStream ann
removeTrailingWhitespace
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions
      {layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine (OutputOptions -> Int
outputOptionsPageWidth OutputOptions
opts) Double
1}
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Int -> Doc ann -> Doc ann
indent (OutputOptions -> Int
outputOptionsInitialIndent OutputOptions
opts)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> [Expr] -> Doc Annotation
prettyExprs' OutputOptions
opts
    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
  [] -> forall a. Monoid a => a
mempty
  Expr
x : [Expr]
xs -> OutputOptions -> Expr -> Doc Annotation
prettyExpr OutputOptions
opts Expr
x 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 = forall ann. [Doc ann] -> Doc ann
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
          forall ann. Int -> Doc ann -> Doc ann
nest Int
2 Doc Annotation
doc
        else
          -- put the expression on a new line, indented (unless grouped)
          forall ann. Int -> Doc ann -> Doc ann
nest (OutputOptions -> Int
outputOptionsIndentAmount OutputOptions
opts) forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann
line' 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 forall ann. Doc ann -> Doc ann
group else forall a. a -> a
id) 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 -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
Quote Doc Annotation
"\"") forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
String forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$
    case OutputOptions -> StringOutputStyle
outputOptionsStringStyle OutputOptions
opts of
      StringOutputStyle
Literal -> String
s
      StringOutputStyle
EscapeNonPrintable -> ShowS
escapeNonPrintable forall a b. (a -> b) -> a -> b
$ ShowS
readStr String
s
      StringOutputStyle
DoNotEscapeNonPrintable -> ShowS
readStr String
s
  CharLit String
s -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
Quote Doc Annotation
"'") forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
String forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty String
s
  Other String
s -> forall a ann. Pretty a => a -> Doc ann
pretty String
s
  NumberLit String
n -> forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
Num forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty String
n
  where
    readStr :: String -> String
    readStr :: ShowS
readStr String
s = forall a. a -> Maybe a -> a
fromMaybe String
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ Char
'"' forall a. a -> [a] -> [a]
: String
s 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) =
      forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
Open Doc Annotation
open) (forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
Close Doc Annotation
close) forall a b. (a -> b) -> a -> b
$ case [[Expr]]
xss of
        [] -> forall a. Monoid a => a
mempty
        [[Expr]
xs] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr -> Bool
isSimple [Expr]
xs ->
          forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
hcat (forall a b. (a -> b) -> [a] -> [b]
map (OutputOptions -> Expr -> Doc Annotation
prettyExpr OutputOptions
opts) [Expr]
xs) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
space
        [[Expr]]
_ -> forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith Doc Annotation -> Doc Annotation -> Doc Annotation
lineAndCommaSep (forall a b. (a -> b) -> [a] -> [b]
map (\[Expr]
xs -> forall {ann}. [Expr] -> Doc ann
spaceIfNeeded [Expr]
xs forall a. Semigroup a => a -> a -> a
<> OutputOptions -> [Expr] -> Doc Annotation
prettyExprs OutputOptions
opts [Expr]
xs) [[Expr]]
xss)
          forall a. Semigroup a => a -> a -> a
<> if OutputOptions -> Bool
outputOptionsCompactParens OutputOptions
opts then forall ann. Doc ann
space else forall ann. Doc ann
line
          where
            spaceIfNeeded :: [Expr] -> Doc ann
spaceIfNeeded = \case
              Other (Char
' ' : String
_) : [Expr]
_ -> forall a. Monoid a => a
mempty
              [Expr]
_ -> forall ann. Doc ann
space
    lineAndCommaSep :: Doc Annotation -> Doc Annotation -> Doc Annotation
lineAndCommaSep Doc Annotation
x Doc Annotation
y = Doc Annotation
x forall a. Semigroup a => a -> a -> a
<> forall {a}. Monoid a => Bool -> a -> a
munless (OutputOptions -> Bool
outputOptionsCompact OutputOptions
opts) forall ann. Doc ann
line' forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
annotate Annotation
Comma 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 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 -> 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
..} -> forall s a. State s a -> s -> a
evalState (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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 -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a. Tape a -> Tape a
moveR forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. Tape a -> a
tapeHead
        Annotation
Close -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. Tape a -> a
tapeHead forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a. Tape a -> Tape a
moveL
        Annotation
Comma -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. Tape a -> a
tapeHead
        Annotation
Quote -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorQuote
        Annotation
String -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorString
        Annotation
Num -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorNum
      initialTape :: Tape Style
initialTape = Tape
        { tapeLeft :: Stream Style
tapeLeft = forall t. t -> Stream t
streamRepeat Style
colorError
        , tapeHead :: Style
tapeHead = Style
colorError
        , tapeRight :: Stream Style
tapeRight = forall a. NonEmpty a -> Stream a
streamCycle forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Style
colorNull)
            forall a b. (a -> b) -> a -> b
$ 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Annotation -> Annotation -> Bool
$c/= :: Annotation -> Annotation -> Bool
== :: Annotation -> Annotation -> Bool
$c== :: Annotation -> Annotation -> Bool
Eq, Int -> Annotation -> ShowS
[Annotation] -> ShowS
Annotation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Annotation] -> ShowS
$cshowList :: [Annotation] -> ShowS
show :: Annotation -> String
$cshow :: Annotation -> String
showsPrec :: Int -> Annotation -> ShowS
$cshowsPrec :: Int -> 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 = 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 forall a. Eq a => a -> a -> Bool
== Char
'\n' = (Char
cforall a. a -> [a] -> [a]
:)
  | Bool
otherwise = (Char
'\\'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'x'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  { 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
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 :: forall a. Tape a -> Tape a
moveL (Tape (a
l :.. Stream a
ls) a
c Stream a
rs) = forall a. Stream a -> a -> Stream a -> Tape a
Tape Stream a
ls a
l (a
c 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)) = forall a. Stream a -> a -> Stream a -> Tape a
Tape (a
c 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
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 :: forall t. t -> Stream t
streamRepeat t
x = t
x forall a. a -> Stream a -> Stream a
:.. 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. a -> Stream a -> Stream a
(:..) (forall a. NonEmpty a -> Stream a
streamCycle NonEmpty a
xs) NonEmpty a
xs