{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Pretty.Simple.Internal.Printer
where
#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)
data CheckColorTty
= CheckColorTty
| NoCheckColorTty
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)
data StringOutputStyle
= Literal
| EscapeNonPrintable
| DoNotEscapeNonPrintable
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 OutputOptions = OutputOptions
{ OutputOptions -> Int
outputOptionsIndentAmount :: Int
, OutputOptions -> Int
outputOptionsPageWidth :: Int
, OutputOptions -> Bool
outputOptionsCompact :: Bool
, OutputOptions -> Bool
outputOptionsCompactParens :: Bool
, OutputOptions -> Int
outputOptionsInitialIndent :: Int
, OutputOptions -> Maybe ColorOptions
outputOptionsColorOptions :: Maybe ColorOptions
, OutputOptions -> StringOutputStyle
outputOptionsStringStyle :: StringOutputStyle
} 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)
defaultOutputOptionsDarkBg :: OutputOptions
defaultOutputOptionsDarkBg :: OutputOptions
defaultOutputOptionsDarkBg =
OutputOptions
defaultOutputOptionsNoColor
{ outputOptionsColorOptions :: Maybe ColorOptions
outputOptionsColorOptions = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions
defaultColorOptionsDarkBg }
defaultOutputOptionsLightBg :: OutputOptions
defaultOutputOptionsLightBg :: OutputOptions
defaultOutputOptionsLightBg =
OutputOptions
defaultOutputOptionsNoColor
{ outputOptionsColorOptions :: Maybe ColorOptions
outputOptionsColorOptions = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions
defaultColorOptionsLightBg }
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
}
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
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
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
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
Int -> Doc Annotation -> Doc Annotation
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 Doc Annotation
doc
else
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
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
<> 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
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
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
}
data Annotation
= Open
| Close
| Comma
| Quote
| String
| Num
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
""
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)
data Tape a = Tape
{ Tape a -> Stream a
tapeLeft :: Stream a
, Tape a -> a
tapeHead :: a
, Tape a -> Stream a
tapeRight :: Stream a
} 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
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)
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
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
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
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