{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SCargot.Print
(
encodeOne
, encode
, encodeOneLazy
, encodeLazy
, SExprPrinter
, Indent(..)
, setFromCarrier
, setMaxWidth
, removeMaxWidth
, setIndentAmount
, setIndentStrategy
, basicPrint
, flatPrint
, unconstrainedPrint
) where
import qualified Data.Foldable as F
import Data.Monoid ((<>))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Traversable as T
import Data.SCargot.Repr
data Indent
= Swing
| SwingAfter Int
| Align
deriving (Indent -> Indent -> Bool
(Indent -> Indent -> Bool)
-> (Indent -> Indent -> Bool) -> Eq Indent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Indent -> Indent -> Bool
== :: Indent -> Indent -> Bool
$c/= :: Indent -> Indent -> Bool
/= :: Indent -> Indent -> Bool
Eq, Int -> Indent -> ShowS
[Indent] -> ShowS
Indent -> String
(Int -> Indent -> ShowS)
-> (Indent -> String) -> ([Indent] -> ShowS) -> Show Indent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Indent -> ShowS
showsPrec :: Int -> Indent -> ShowS
$cshow :: Indent -> String
show :: Indent -> String
$cshowList :: [Indent] -> ShowS
showList :: [Indent] -> ShowS
Show)
data SExprPrinter atom carrier = SExprPrinter
{ forall atom carrier. SExprPrinter atom carrier -> atom -> Text
atomPrinter :: atom -> Text
, forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
fromCarrier :: carrier -> SExpr atom
, forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
swingIndent :: SExpr atom -> Indent
, forall atom carrier. SExprPrinter atom carrier -> Int
indentAmount :: Int
, forall atom carrier. SExprPrinter atom carrier -> Maybe Int
maxWidth :: Maybe Int
, forall atom carrier. SExprPrinter atom carrier -> Bool
indentPrint :: Bool
}
flatPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint :: forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint = (\SExprPrinter atom (SExpr atom)
p -> SExprPrinter atom (SExpr atom)
p { indentPrint = False}) (SExprPrinter atom (SExpr atom) -> SExprPrinter atom (SExpr atom))
-> ((atom -> Text) -> SExprPrinter atom (SExpr atom))
-> (atom -> Text)
-> SExprPrinter atom (SExpr atom)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExprPrinter atom (SExpr atom) -> SExprPrinter atom (SExpr atom)
forall atom carrier.
SExprPrinter atom carrier -> SExprPrinter atom carrier
removeMaxWidth (SExprPrinter atom (SExpr atom) -> SExprPrinter atom (SExpr atom))
-> ((atom -> Text) -> SExprPrinter atom (SExpr atom))
-> (atom -> Text)
-> SExprPrinter atom (SExpr atom)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (atom -> Text) -> SExprPrinter atom (SExpr atom)
forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
basicPrint
basicPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
basicPrint :: forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
basicPrint atom -> Text
printer = SExprPrinter
{ atomPrinter :: atom -> Text
atomPrinter = atom -> Text
printer
, fromCarrier :: SExpr atom -> SExpr atom
fromCarrier = SExpr atom -> SExpr atom
forall a. a -> a
id
, swingIndent :: SExpr atom -> Indent
swingIndent = Indent -> SExpr atom -> Indent
forall a b. a -> b -> a
const Indent
Swing
, indentAmount :: Int
indentAmount = Int
2
, maxWidth :: Maybe Int
maxWidth = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
80
, indentPrint :: Bool
indentPrint = Bool
True
}
unconstrainedPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
unconstrainedPrint :: forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
unconstrainedPrint = SExprPrinter atom (SExpr atom) -> SExprPrinter atom (SExpr atom)
forall atom carrier.
SExprPrinter atom carrier -> SExprPrinter atom carrier
removeMaxWidth (SExprPrinter atom (SExpr atom) -> SExprPrinter atom (SExpr atom))
-> ((atom -> Text) -> SExprPrinter atom (SExpr atom))
-> (atom -> Text)
-> SExprPrinter atom (SExpr atom)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (atom -> Text) -> SExprPrinter atom (SExpr atom)
forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
basicPrint
data Size = Size
{ Size -> Int
sizeSum :: !Int
, Size -> Int
sizeMax :: !Int
} deriving (Int -> Size -> ShowS
[Size] -> ShowS
Size -> String
(Int -> Size -> ShowS)
-> (Size -> String) -> ([Size] -> ShowS) -> Show Size
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Size -> ShowS
showsPrec :: Int -> Size -> ShowS
$cshow :: Size -> String
show :: Size -> String
$cshowList :: [Size] -> ShowS
showList :: [Size] -> ShowS
Show)
data Intermediate
= IAtom Text
| IList Indent Size Intermediate (Seq.Seq Intermediate) (Maybe Text)
| IEmpty
deriving Int -> Intermediate -> ShowS
[Intermediate] -> ShowS
Intermediate -> String
(Int -> Intermediate -> ShowS)
-> (Intermediate -> String)
-> ([Intermediate] -> ShowS)
-> Show Intermediate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Intermediate -> ShowS
showsPrec :: Int -> Intermediate -> ShowS
$cshow :: Intermediate -> String
show :: Intermediate -> String
$cshowList :: [Intermediate] -> ShowS
showList :: [Intermediate] -> ShowS
Show
sizeOf :: Intermediate -> Size
sizeOf :: Intermediate -> Size
sizeOf Intermediate
IEmpty = Int -> Int -> Size
Size Int
2 Int
2
sizeOf (IAtom Text
t) = Int -> Int -> Size
Size Int
len Int
len where len :: Int
len = Text -> Int
T.length Text
t
sizeOf (IList Indent
_ (Size Int
n Int
m) Intermediate
_ Seq Intermediate
_ Maybe Text
_) = Int -> Int -> Size
Size (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
concatSize :: Size -> Size -> Size
concatSize :: Size -> Size -> Size
concatSize Size
l Size
r = Size
{ sizeSum :: Int
sizeSum = Size -> Int
sizeSum Size
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Size -> Int
sizeSum Size
r
, sizeMax :: Int
sizeMax = Size -> Int
sizeMax Size
l Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Size -> Int
sizeMax Size
r
}
toIntermediate :: SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
toIntermediate :: forall a. SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
toIntermediate
SExprPrinter { atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
atomPrinter = a -> Text
printAtom
, swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
swingIndent = SExpr a -> Indent
swing
} = SExpr a -> Intermediate
headOf
where
headOf :: SExpr a -> Intermediate
headOf (SAtom a
a) = Text -> Intermediate
IAtom (a -> Text
printAtom a
a)
headOf SExpr a
SNil = Intermediate
IEmpty
headOf (SCons SExpr a
x SExpr a
xs) =
Indent
-> Intermediate
-> Seq Intermediate
-> SExpr a
-> Size
-> Intermediate
gather (SExpr a -> Indent
swing SExpr a
x) Intermediate
hd Seq Intermediate
forall a. Seq a
Seq.empty SExpr a
xs (Intermediate -> Size
sizeOf Intermediate
hd) where hd :: Intermediate
hd = SExpr a -> Intermediate
headOf SExpr a
x
gather :: Indent
-> Intermediate
-> Seq Intermediate
-> SExpr a
-> Size
-> Intermediate
gather Indent
sw Intermediate
hd Seq Intermediate
rs SExpr a
SNil Size
sz =
Indent
-> Size
-> Intermediate
-> Seq Intermediate
-> Maybe Text
-> Intermediate
IList Indent
sw Size
sz Intermediate
hd Seq Intermediate
rs Maybe Text
forall a. Maybe a
Nothing
gather Indent
sw Intermediate
hd Seq Intermediate
rs (SAtom a
a) Size
sz =
Indent
-> Size
-> Intermediate
-> Seq Intermediate
-> Maybe Text
-> Intermediate
IList Indent
sw (Size
sz Size -> Size -> Size
`concatSize` Size
aSize) Intermediate
hd Seq Intermediate
rs (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
aStr)
where aSize :: Size
aSize = Int -> Int -> Size
Size Int
aLen Int
aLen
aLen :: Int
aLen = Text -> Int
T.length Text
aStr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
aStr :: Text
aStr = a -> Text
printAtom a
a
gather Indent
sw Intermediate
hd Seq Intermediate
rs (SCons SExpr a
x SExpr a
xs) Size
sz =
Indent
-> Intermediate
-> Seq Intermediate
-> SExpr a
-> Size
-> Intermediate
gather Indent
sw Intermediate
hd (Seq Intermediate
rs Seq Intermediate -> Intermediate -> Seq Intermediate
forall a. Seq a -> a -> Seq a
Seq.|> Intermediate
x') SExpr a
xs (Size
sz Size -> Size -> Size
`concatSize` Intermediate -> Size
sizeOf Intermediate
x')
where x' :: Intermediate
x' = SExpr a -> Intermediate
headOf SExpr a
x
unboundIndentPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
unboundIndentPrintSExpr :: forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
unboundIndentPrintSExpr SExprPrinter a (SExpr a)
spec = Seq Builder -> Text
finalize (Seq Builder -> Text)
-> (SExpr a -> Seq Builder) -> SExpr a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Intermediate -> Seq Builder
go (Intermediate -> Seq Builder)
-> (SExpr a -> Intermediate) -> SExpr a -> Seq Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
forall a. SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
toIntermediate SExprPrinter a (SExpr a)
spec
where
finalize :: Seq Builder -> Text
finalize = Builder -> Text
B.toLazyText (Builder -> Text)
-> (Seq Builder -> Builder) -> Seq Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Builder -> Builder
joinLinesS
go :: Intermediate -> Seq.Seq B.Builder
go :: Intermediate -> Seq Builder
go (IAtom Text
t) = Builder -> Seq Builder
forall a. a -> Seq a
Seq.singleton (Text -> Builder
B.fromText Text
t)
go Intermediate
IEmpty = Builder -> Seq Builder
forall a. a -> Seq a
Seq.singleton (String -> Builder
B.fromString String
"()")
go (IList Indent
iv Size
_ Intermediate
initial Seq Intermediate
values Maybe Text
rest)
| Just Seq Builder
strings <- (Intermediate -> Maybe Builder)
-> Seq Intermediate -> Maybe (Seq Builder)
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) -> Seq a -> f (Seq b)
T.traverse Intermediate -> Maybe Builder
ppBasic (Intermediate
initial Intermediate -> Seq Intermediate -> Seq Intermediate
forall a. a -> Seq a -> Seq a
Seq.<| Seq Intermediate
values) =
Builder -> Seq Builder
forall a. a -> Seq a
Seq.singleton (Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
buildUnwords Seq Builder
strings Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Builder
pTail Maybe Text
rest)
| Indent
Swing <- Indent
iv =
let butLast :: Seq Builder
butLast = Seq Builder -> Seq Builder
insertParen (Intermediate -> Seq Builder
go Intermediate
initial) Seq Builder -> Seq Builder -> Seq Builder
forall a. Semigroup a => a -> a -> a
<> (Builder -> Builder) -> Seq Builder -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Builder
doIndent ((Intermediate -> Seq Builder) -> Seq Intermediate -> Seq Builder
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Intermediate -> Seq Builder
go Seq Intermediate
values)
in Maybe Text -> Seq Builder -> Seq Builder
handleTail Maybe Text
rest Seq Builder
butLast
| SwingAfter Int
n <- Indent
iv =
let (Seq Intermediate
hs, Seq Intermediate
xs) = Int -> Seq Intermediate -> (Seq Intermediate, Seq Intermediate)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n (Intermediate
initial Intermediate -> Seq Intermediate -> Seq Intermediate
forall a. a -> Seq a -> Seq a
Seq.<| Seq Intermediate
values)
hd :: Builder
hd = Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
buildUnwords ((Intermediate -> Seq Builder) -> Seq Intermediate -> Seq Builder
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Intermediate -> Seq Builder
go Seq Intermediate
hs)
butLast :: Seq Builder
butLast = Builder
hd Builder -> Seq Builder -> Seq Builder
forall a. a -> Seq a -> Seq a
Seq.<| (Builder -> Builder) -> Seq Builder -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Builder
doIndent ((Intermediate -> Seq Builder) -> Seq Intermediate -> Seq Builder
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Intermediate -> Seq Builder
go Seq Intermediate
xs)
in Maybe Text -> Seq Builder -> Seq Builder
handleTail Maybe Text
rest Seq Builder
butLast
| Bool
otherwise =
let
len :: Int64
len = Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Seq Int64 -> Int64
forall a. Ord a => Seq a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
F.maximum ((Builder -> Int64) -> Seq Builder -> Seq Int64
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Int64
TL.length (Text -> Int64) -> (Builder -> Text) -> Builder -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText) (Intermediate -> Seq Builder
go Intermediate
initial))
in case Seq Intermediate -> ViewL Intermediate
forall a. Seq a -> ViewL a
Seq.viewl Seq Intermediate
values of
ViewL Intermediate
Seq.EmptyL -> Seq Builder -> Seq Builder
insertParen (Seq Builder -> Seq Builder
insertCloseParen (Intermediate -> Seq Builder
go Intermediate
initial))
Intermediate
y Seq.:< Seq Intermediate
ys ->
let hd :: Builder
hd = Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
buildUnwords ((Intermediate -> Seq Builder) -> Seq Intermediate -> Seq Builder
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Intermediate -> Seq Builder
go ([Intermediate] -> Seq Intermediate
forall a. [a] -> Seq a
Seq.fromList [Intermediate
initial, Intermediate
y]))
butLast :: Seq Builder
butLast = Builder
hd Builder -> Seq Builder -> Seq Builder
forall a. a -> Seq a -> Seq a
Seq.<| (Builder -> Builder) -> Seq Builder -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Builder -> Builder
doIndentOf (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)) ((Intermediate -> Seq Builder) -> Seq Intermediate -> Seq Builder
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Intermediate -> Seq Builder
go Seq Intermediate
ys)
in Maybe Text -> Seq Builder -> Seq Builder
handleTail Maybe Text
rest Seq Builder
butLast
doIndent :: B.Builder -> B.Builder
doIndent :: Builder -> Builder
doIndent = Int -> Builder -> Builder
doIndentOf (SExprPrinter a (SExpr a) -> Int
forall atom carrier. SExprPrinter atom carrier -> Int
indentAmount SExprPrinter a (SExpr a)
spec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
doIndentOf :: Int -> B.Builder -> B.Builder
doIndentOf :: Int -> Builder -> Builder
doIndentOf Int
n Builder
b = Text -> Builder
B.fromText (Int -> Text -> Text
T.replicate Int
n Text
" ") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b
insertParen :: Seq.Seq B.Builder -> Seq.Seq B.Builder
insertParen :: Seq Builder -> Seq Builder
insertParen Seq Builder
s = case Seq Builder -> ViewL Builder
forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
ViewL Builder
Seq.EmptyL -> Seq Builder
s
Builder
x Seq.:< Seq Builder
xs -> (Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
x) Builder -> Seq Builder -> Seq Builder
forall a. a -> Seq a -> Seq a
Seq.<| Seq Builder
xs
handleTail :: Maybe Text -> Seq.Seq B.Builder -> Seq.Seq B.Builder
handleTail :: Maybe Text -> Seq Builder -> Seq Builder
handleTail Maybe Text
Nothing = Seq Builder -> Seq Builder
insertCloseParen
handleTail (Just Text
t) =
let txtInd :: Builder
txtInd = Text -> Builder
B.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (SExprPrinter a (SExpr a) -> Int
forall atom carrier. SExprPrinter atom carrier -> Int
indentAmount SExprPrinter a (SExpr a)
spec) Text
" "
sep :: Builder
sep = String -> Builder
B.fromString String
" . "
in (Seq Builder -> Builder -> Seq Builder
forall a. Seq a -> a -> Seq a
Seq.|> (Builder
txtInd Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')'))
insertCloseParen :: Seq.Seq B.Builder -> Seq.Seq B.Builder
insertCloseParen :: Seq Builder -> Seq Builder
insertCloseParen Seq Builder
s = case Seq Builder -> ViewR Builder
forall a. Seq a -> ViewR a
Seq.viewr Seq Builder
s of
ViewR Builder
Seq.EmptyR -> Builder -> Seq Builder
forall a. a -> Seq a
Seq.singleton (Char -> Builder
B.singleton Char
')')
Seq Builder
xs Seq.:> Builder
x -> Seq Builder
xs Seq Builder -> Builder -> Seq Builder
forall a. Seq a -> a -> Seq a
Seq.|> (Builder
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')')
buildUnwords :: Seq Builder -> Builder
buildUnwords Seq Builder
sq =
case Seq Builder -> ViewL Builder
forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
sq of
ViewL Builder
Seq.EmptyL -> Builder
forall a. Monoid a => a
mempty
Builder
t Seq.:< Seq Builder
ts -> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder -> Builder) -> Seq Builder -> Builder
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (\ Builder
x -> Char -> Builder
B.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
x) Seq Builder
ts
pTail :: Maybe Text -> Builder
pTail Maybe Text
Nothing = Char -> Builder
B.singleton Char
')'
pTail (Just Text
t) = String -> Builder
B.fromString String
" . " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')'
ppBasic :: Intermediate -> Maybe Builder
ppBasic (IAtom Text
t) = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Text -> Builder
B.fromText Text
t)
ppBasic (Intermediate
IEmpty) = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (String -> Builder
B.fromString String
"()")
ppBasic Intermediate
_ = Maybe Builder
forall a. Maybe a
Nothing
setFromCarrier :: (c -> b) -> SExprPrinter a b -> SExprPrinter a c
setFromCarrier :: forall c b a. (c -> b) -> SExprPrinter a b -> SExprPrinter a c
setFromCarrier c -> b
fc SExprPrinter a b
pr = SExprPrinter a b
pr { fromCarrier = fromCarrier pr . fc }
setMaxWidth :: Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier
setMaxWidth :: forall atom carrier.
Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier
setMaxWidth Int
n SExprPrinter atom carrier
pr = SExprPrinter atom carrier
pr { maxWidth = Just n }
removeMaxWidth :: SExprPrinter atom carrier -> SExprPrinter atom carrier
removeMaxWidth :: forall atom carrier.
SExprPrinter atom carrier -> SExprPrinter atom carrier
removeMaxWidth SExprPrinter atom carrier
pr = SExprPrinter atom carrier
pr { maxWidth = Nothing }
setIndentAmount :: Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier
setIndentAmount :: forall atom carrier.
Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier
setIndentAmount Int
n SExprPrinter atom carrier
pr = SExprPrinter atom carrier
pr { indentAmount = n }
setIndentStrategy :: (SExpr atom -> Indent) -> SExprPrinter atom carrier -> SExprPrinter atom carrier
setIndentStrategy :: forall atom carrier.
(SExpr atom -> Indent)
-> SExprPrinter atom carrier -> SExprPrinter atom carrier
setIndentStrategy SExpr atom -> Indent
st SExprPrinter atom carrier
pr = SExprPrinter atom carrier
pr { swingIndent = st }
spaceDot :: B.Builder
spaceDot :: Builder
spaceDot = Char -> Builder
B.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
'.' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
' '
indent :: Int -> B.Builder -> B.Builder
indent :: Int -> Builder -> Builder
indent Int
n Builder
ts =
[Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Char -> Builder
B.singleton Char
' ' | Int
_ <- [Int
1..Int
n]] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ts
joinLinesS :: Seq.Seq B.Builder -> B.Builder
joinLinesS :: Seq Builder -> Builder
joinLinesS Seq Builder
s = case Seq Builder -> ViewL Builder
forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
ViewL Builder
Seq.EmptyL -> Builder
""
Builder
t Seq.:< Seq Builder
ts
| Seq Builder -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Seq Builder
ts -> Builder
t
| Bool
otherwise -> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
B.fromString String
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
joinLinesS Seq Builder
ts
unwordsS :: Seq.Seq B.Builder -> B.Builder
unwordsS :: Seq Builder -> Builder
unwordsS Seq Builder
s = case Seq Builder -> ViewL Builder
forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
ViewL Builder
Seq.EmptyL -> Builder
""
Builder
t Seq.:< Seq Builder
ts
| Seq Builder -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Seq Builder
ts -> Builder
t
| Bool
otherwise -> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
unwordsS Seq Builder
ts
indentAllS :: Int -> Seq.Seq B.Builder -> B.Builder
indentAllS :: Int -> Seq Builder -> Builder
indentAllS Int
n Seq Builder
s = if Seq Builder -> Bool
forall a. Seq a -> Bool
Seq.null Seq Builder
s
then Builder
""
else (Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Seq Builder -> Builder
joinLinesS (Seq Builder -> Builder) -> Seq Builder -> Builder
forall a b. (a -> b) -> a -> b
$ (Builder -> Builder) -> Seq Builder -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Builder -> Builder
indent Int
n) Seq Builder
s
indentSubsequentS :: Int -> Seq.Seq B.Builder -> B.Builder
indentSubsequentS :: Int -> Seq Builder -> Builder
indentSubsequentS Int
n Seq Builder
s = case Seq Builder -> ViewL Builder
forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
ViewL Builder
Seq.EmptyL -> Builder
""
Builder
t Seq.:< Seq Builder
ts
| Seq Builder -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Seq Builder
ts -> Builder
t
| Bool
otherwise -> Seq Builder -> Builder
joinLinesS (Builder
t Builder -> Seq Builder -> Seq Builder
forall a. a -> Seq a -> Seq a
Seq.<| (Builder -> Builder) -> Seq Builder -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Builder -> Builder
indent Int
n) Seq Builder
ts)
prettyPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
prettyPrintSExpr :: forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
prettyPrintSExpr pr :: SExprPrinter a (SExpr a)
pr@SExprPrinter { Bool
Int
Maybe Int
a -> Text
SExpr a -> SExpr a
SExpr a -> Indent
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
atomPrinter :: a -> Text
fromCarrier :: SExpr a -> SExpr a
swingIndent :: SExpr a -> Indent
indentAmount :: Int
maxWidth :: Maybe Int
indentPrint :: Bool
.. } SExpr a
expr = case Maybe Int
maxWidth of
Maybe Int
Nothing
| Bool
indentPrint -> SExprPrinter a (SExpr a) -> SExpr a -> Text
forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
unboundIndentPrintSExpr SExprPrinter a (SExpr a)
pr (SExpr a -> SExpr a
fromCarrier SExpr a
expr)
| Bool
otherwise -> SExpr Text -> Text
flatPrintSExpr ((a -> Text) -> SExpr a -> SExpr Text
forall a b. (a -> b) -> SExpr a -> SExpr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Text
atomPrinter (SExpr a -> SExpr a
fromCarrier SExpr a
expr))
Just Int
w -> Int -> SExprPrinter a (SExpr a) -> SExpr a -> Text
forall a. Int -> SExprPrinter a (SExpr a) -> SExpr a -> Text
indentPrintSExpr' Int
w SExprPrinter a (SExpr a)
pr SExpr a
expr
indentPrintSExpr' :: Int -> SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
indentPrintSExpr' :: forall a. Int -> SExprPrinter a (SExpr a) -> SExpr a -> Text
indentPrintSExpr' Int
maxAmt pr :: SExprPrinter a (SExpr a)
pr@SExprPrinter { Bool
Int
Maybe Int
a -> Text
SExpr a -> SExpr a
SExpr a -> Indent
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
atomPrinter :: a -> Text
fromCarrier :: SExpr a -> SExpr a
swingIndent :: SExpr a -> Indent
indentAmount :: Int
maxWidth :: Maybe Int
indentPrint :: Bool
.. } = Builder -> Text
B.toLazyText (Builder -> Text) -> (SExpr a -> Builder) -> SExpr a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Intermediate -> Builder
pp Int
0 (Intermediate -> Builder)
-> (SExpr a -> Intermediate) -> SExpr a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
forall a. SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
toIntermediate SExprPrinter a (SExpr a)
pr
where
pp :: Int -> Intermediate -> Builder
pp Int
_ Intermediate
IEmpty = String -> Builder
B.fromString String
"()"
pp Int
_ (IAtom Text
t) = Text -> Builder
B.fromText Text
t
pp Int
ind (IList Indent
i Size
sz Intermediate
h Seq Intermediate
values Maybe Text
end) =
Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
hd Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
body Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tl Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')'
where
tl :: Builder
tl = case Maybe Text
end of
Maybe Text
Nothing -> Builder
forall a. Monoid a => a
mempty
Just Text
x -> String -> Builder
B.fromString String
" . " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
x
hd :: Builder
hd = Int -> Intermediate -> Builder
pp (Int
indInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Intermediate
h
indented :: Builder
indented =
case Indent
i of
SwingAfter Int
n ->
let (Seq Intermediate
l, Seq Intermediate
ls) = Int -> Seq Intermediate -> (Seq Intermediate, Seq Intermediate)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n Seq Intermediate
values
t :: Builder
t = Seq Builder -> Builder
unwordsS ((Intermediate -> Builder) -> Seq Intermediate -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp (Int
indInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Seq Intermediate
l)
nextInd :: Int
nextInd = Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentAmount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
ts :: Builder
ts = Int -> Seq Builder -> Builder
indentAllS Int
nextInd ((Intermediate -> Builder) -> Seq Intermediate -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp Int
nextInd) Seq Intermediate
ls)
in Char -> Builder
B.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ts
Indent
Swing ->
let nextInd :: Int
nextInd = Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentAmount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
in Int -> Seq Builder -> Builder
indentAllS Int
nextInd ((Intermediate -> Builder) -> Seq Intermediate -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp Int
nextInd) Seq Intermediate
values)
Indent
Align ->
let headWidth :: Int
headWidth = Size -> Int
sizeSum (Intermediate -> Size
sizeOf Intermediate
h)
nextInd :: Int
nextInd = Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
headWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
in Char -> Builder
B.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Int -> Seq Builder -> Builder
indentSubsequentS Int
nextInd ((Intermediate -> Builder) -> Seq Intermediate -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp Int
nextInd) Seq Intermediate
values)
body :: Builder
body
| Seq Intermediate -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Intermediate
values Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Builder
forall a. Monoid a => a
mempty
| Size -> Int
sizeSum Size
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ind Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxAmt = Builder
indented
| Bool
otherwise =
Char -> Builder
B.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
unwordsS ((Intermediate -> Builder) -> Seq Intermediate -> Seq Builder
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Seq Intermediate
values)
flatPrintSExpr :: SExpr Text -> TL.Text
flatPrintSExpr :: SExpr Text -> Text
flatPrintSExpr = Builder -> Text
B.toLazyText (Builder -> Text) -> (SExpr Text -> Builder) -> SExpr Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExpr Text -> Builder
pHead
where
pHead :: SExpr Text -> Builder
pHead (SCons SExpr Text
x SExpr Text
xs) =
Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pHead SExpr Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pTail SExpr Text
xs
pHead (SAtom Text
t) =
Text -> Builder
B.fromText Text
t
pHead SExpr Text
SNil =
Char -> Builder
B.singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')'
pTail :: SExpr Text -> Builder
pTail (SCons SExpr Text
x SExpr Text
xs) =
Char -> Builder
B.singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pHead SExpr Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pTail SExpr Text
xs
pTail (SAtom Text
t) =
Builder
spaceDot Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
B.fromText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
B.singleton Char
')'
pTail SExpr Text
SNil =
Char -> Builder
B.singleton Char
')'
encodeOne :: SExprPrinter atom carrier -> carrier -> Text
encodeOne :: forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOne s :: SExprPrinter atom carrier
s@(SExprPrinter { Bool
Int
Maybe Int
atom -> Text
carrier -> SExpr atom
SExpr atom -> Indent
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
atomPrinter :: atom -> Text
fromCarrier :: carrier -> SExpr atom
swingIndent :: SExpr atom -> Indent
indentAmount :: Int
maxWidth :: Maybe Int
indentPrint :: Bool
.. }) =
Text -> Text
TL.toStrict (Text -> Text) -> (carrier -> Text) -> carrier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExprPrinter atom (SExpr atom) -> SExpr atom -> Text
forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
prettyPrintSExpr (SExprPrinter atom carrier
s { fromCarrier = id }) (SExpr atom -> Text) -> (carrier -> SExpr atom) -> carrier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. carrier -> SExpr atom
fromCarrier
encode :: SExprPrinter atom carrier -> [carrier] -> Text
encode :: forall atom carrier. SExprPrinter atom carrier -> [carrier] -> Text
encode SExprPrinter atom carrier
spec =
Text -> [Text] -> Text
T.intercalate Text
"\n\n" ([Text] -> Text) -> ([carrier] -> [Text]) -> [carrier] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (carrier -> Text) -> [carrier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (SExprPrinter atom carrier -> carrier -> Text
forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOne SExprPrinter atom carrier
spec)
encodeOneLazy :: SExprPrinter atom carrier -> carrier -> TL.Text
encodeOneLazy :: forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOneLazy s :: SExprPrinter atom carrier
s@(SExprPrinter { Bool
Int
Maybe Int
atom -> Text
carrier -> SExpr atom
SExpr atom -> Indent
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
atomPrinter :: atom -> Text
fromCarrier :: carrier -> SExpr atom
swingIndent :: SExpr atom -> Indent
indentAmount :: Int
maxWidth :: Maybe Int
indentPrint :: Bool
.. }) =
SExprPrinter atom (SExpr atom) -> SExpr atom -> Text
forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
prettyPrintSExpr (SExprPrinter atom carrier
s { fromCarrier = id }) (SExpr atom -> Text) -> (carrier -> SExpr atom) -> carrier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. carrier -> SExpr atom
fromCarrier
encodeLazy :: SExprPrinter atom carrier -> [carrier] -> TL.Text
encodeLazy :: forall atom carrier. SExprPrinter atom carrier -> [carrier] -> Text
encodeLazy SExprPrinter atom carrier
spec = Text -> [Text] -> Text
TL.intercalate Text
"\n\n" ([Text] -> Text) -> ([carrier] -> [Text]) -> [carrier] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (carrier -> Text) -> [carrier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (SExprPrinter atom carrier -> carrier -> Text
forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOneLazy SExprPrinter atom carrier
spec)