{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.SCargot.Print
         ( -- * Pretty-Printing
           encodeOne
         , encode
         , encodeOneLazy
         , encodeLazy
           -- * Pretty-Printing Control
         , SExprPrinter
         , Indent(..)
         , setFromCarrier
         , setMaxWidth
         , removeMaxWidth
         , setIndentAmount
         , setIndentStrategy
           -- * Default Printing Strategies
         , 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


-- | The 'Indent' type is used to determine how to indent subsequent
--   s-expressions in a list, after printing the head of the list.  This only
--   applies if the entire list cannot be printed within the allowable
--   'SExprPrinter.maxWidth'; a sub-maxWidth printing will not add newlines or
--   indentation.
data Indent
  = Swing -- ^ A 'Swing' indent will indent subsequent exprs some fixed
          --   amount more than the current line.
          --
          --   > (foo
          --   >   bar
          --   >   baz
          --   >   quux)
          --
          -- Any 'SExprPrinter.indentAmount' applies relative to the entry at the
          -- head of the list; in the above example, the indentAmount is 1.
  | SwingAfter Int -- ^ A 'SwingAfter' @n@ indent will try to print the
                   --   first @n@ expressions after the head on the same
                   --   line as the head, and all after will be swung.
                   --   'SwingAfter' @0@ is equivalent to 'Swing'.
                   --
                   --   > (foo bar
                   --   >   baz
                   --   >   quux)
                   --
                   -- The 'SExprPrinter.indentAmount' is handled in the same way
                   -- as for the 'Swing' setting.
  | Align -- ^ An 'Align' indent will print the first expression after the head
          -- on the same line, and subsequent expressions will be aligned with
          -- that one.  Note that this ignores any 'SExprPrinter.indentAmount'
          -- specified for the printer.
          --
          --   > (foo bar
          --   >      baz
          --   >      quux)
    deriving (Indent -> Indent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Indent -> Indent -> Bool
$c/= :: Indent -> Indent -> Bool
== :: Indent -> Indent -> Bool
$c== :: Indent -> Indent -> Bool
Eq, Int -> Indent -> ShowS
[Indent] -> ShowS
Indent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Indent] -> ShowS
$cshowList :: [Indent] -> ShowS
show :: Indent -> String
$cshow :: Indent -> String
showsPrec :: Int -> Indent -> ShowS
$cshowsPrec :: Int -> Indent -> ShowS
Show)


-- | A 'SExprPrinter' value describes how to print a given value as an
--   s-expression. The @carrier@ type parameter indicates the value
--   that will be printed, and the @atom@ parameter indicates the type
--   that will represent tokens in an s-expression structure.
data SExprPrinter atom carrier = SExprPrinter
  { forall atom carrier. SExprPrinter atom carrier -> atom -> Text
atomPrinter  :: atom -> Text
      -- ^ How to serialize a given atom to 'Text'.
  , forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
fromCarrier  :: carrier -> SExpr atom
      -- ^ How to turn a carrier type back into a 'Sexpr'.
  , forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
swingIndent  :: SExpr atom -> Indent
      -- ^ How to indent subsequent expressions, as determined by
      --   the head of the list.
  , forall atom carrier. SExprPrinter atom carrier -> Int
indentAmount :: Int
      -- ^ How much to indent after a swung indentation, relative to the *head*
      -- element.
  , forall atom carrier. SExprPrinter atom carrier -> Maybe Int
maxWidth     :: Maybe Int
      -- ^ The maximum width (if any) If this is 'None' then the resulting
      --   s-expression might be printed on one line (if
      --   'SExprPrinter.indentPrint' is 'False') and might be pretty-printed in
      --   the most naive way possible (if 'SExprPrinter.indentPrint' is 'True').
  , forall atom carrier. SExprPrinter atom carrier -> Bool
indentPrint :: Bool
      -- ^ Whether to indent or not.
  }


-- | A default 'SExprPrinter' struct that will always print a 'SExpr'
--   as a single line.
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 :: Bool
indentPrint = Bool
False}) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall atom carrier.
SExprPrinter atom carrier -> SExprPrinter atom carrier
removeMaxWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
basicPrint

-- | A default 'SExprPrinter' struct that will always swing subsequent
--   expressions onto later lines if they're too long, indenting them
--   by two spaces, and uses a soft maximum width of 80 characters
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  = forall a. a -> a
id
  , swingIndent :: SExpr atom -> Indent
swingIndent  = forall a b. a -> b -> a
const Indent
Swing
  , indentAmount :: Int
indentAmount = Int
2
  , maxWidth :: Maybe Int
maxWidth     = forall a. a -> Maybe a
Just Int
80
  , indentPrint :: Bool
indentPrint  = Bool
True
  }

-- | A default 'SExprPrinter' struct that will always swing subsequent
-- expressions onto later lines if they're too long, indenting them by
-- two spaces, but makes no effort to keep the pretty-printed sources
-- inside a maximum width. In the case that we want indented printing
-- but don't care about a "maximum" width, we can print more
-- efficiently than in other situations.
unconstrainedPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
unconstrainedPrint :: forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
unconstrainedPrint = forall atom carrier.
SExprPrinter atom carrier -> SExprPrinter atom carrier
removeMaxWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Size] -> ShowS
$cshowList :: [Size] -> ShowS
show :: Size -> String
$cshow :: Size -> String
showsPrec :: Int -> Size -> ShowS
$cshowsPrec :: Int -> Size -> ShowS
Show)

-- | This is an intermediate representation which is like (but not
-- identical to) a RichSExpr representation. In particular, it has a
-- special case for empty lists, and it also keeps a single piece of
-- indent information around for each list
data Intermediate
  = IAtom Text
  -- ^ An atom, already serialized
  | IList Indent Size Intermediate (Seq.Seq Intermediate) (Maybe Text)
  -- ^ A (possibly-improper) list, with the intended indentation
  -- strategy, the head of the list, the main set of elements, and the
  -- final improper element (if it exists)
  | IEmpty
  -- ^ An empty list
    deriving Int -> Intermediate -> ShowS
[Intermediate] -> ShowS
Intermediate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Intermediate] -> ShowS
$cshowList :: [Intermediate] -> ShowS
show :: Intermediate -> String
$cshow :: Intermediate -> String
showsPrec :: Int -> Intermediate -> ShowS
$cshowsPrec :: Int -> 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 forall a. Num a => a -> a -> a
+ Int
2) (Int
m 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 forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Size -> Int
sizeSum Size
r  -- 1 for the ' ' between elements
  , sizeMax :: Int
sizeMax = Size -> Int
sizeMax Size
l 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 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 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 (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 forall a. Num a => a -> a -> a
+ Int
2 -- 2 for the ". " between the pair
              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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Intermediate -> Seq Builder
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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) = forall a. a -> Seq a
Seq.singleton (Text -> Builder
B.fromText Text
t)
    go Intermediate
IEmpty    = forall a. a -> Seq a
Seq.singleton (String -> Builder
B.fromString String
"()")
    -- this case should never be called with an empty argument to
    -- @values@, as that should have been translated to @IEmpty@
    -- instead.
    go (IList Indent
iv Size
_ Intermediate
initial Seq Intermediate
values Maybe Text
rest)
      -- if we're looking at an s-expression that has no nested
      -- s-expressions, then we might as well consider it flat and let
      -- it take the whole line
      | Just Seq Builder
strings <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse Intermediate -> Maybe Builder
ppBasic (Intermediate
initial forall a. a -> Seq a -> Seq a
Seq.<| Seq Intermediate
values) =
        forall a. a -> Seq a
Seq.singleton (Char -> Builder
B.singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
buildUnwords Seq Builder
strings forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Builder
pTail Maybe Text
rest)

      -- it's not "flat", so we might want to swing after the first thing
      | Indent
Swing <- Indent
iv =
          -- if this match fails, then it means we've failed to
          -- convert to an Intermediate correctly!
          let butLast :: Seq Builder
butLast = Seq Builder -> Seq Builder
insertParen (Intermediate -> Seq Builder
go Intermediate
initial) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Builder
doIndent (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

      -- ...or after several things
      | SwingAfter Int
n <- Indent
iv =
          let (Seq Intermediate
hs, Seq Intermediate
xs) = forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n (Intermediate
initial forall a. a -> Seq a -> Seq a
Seq.<| Seq Intermediate
values)
              hd :: Builder
hd = Char -> Builder
B.singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
buildUnwords (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 forall a. a -> Seq a -> Seq a
Seq.<| forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Builder
doIndent (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

      -- the 'align' choice is clunkier because we need to know how
      -- deep to indent, so we have to force the first builder to grab its size
      | Bool
otherwise =
        let -- so we grab that and figure out its length plus two (for
            -- the leading paren and the following space). This uses a
            -- max because it's possible the first thing is itself a
            -- multi-line s-expression (in which case it seems like
            -- using the Align strategy is a terrible idea, but who am
            -- I to quarrel with the wild fruits upon the Tree of
            -- Life?)
            len :: Int64
len = Int64
2 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
F.maximum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Int64
TL.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText) (Intermediate -> Seq Builder
go Intermediate
initial))
        in case forall a. Seq a -> ViewL a
Seq.viewl Seq Intermediate
values of
          -- if there's nothing after the head of the expression, then
          -- we simply close it
          ViewL Intermediate
Seq.EmptyL -> Seq Builder -> Seq Builder
insertParen (Seq Builder -> Seq Builder
insertCloseParen (Intermediate -> Seq Builder
go Intermediate
initial))
          -- otherwise, we put the first two things on the same line
          -- with spaces and everything else gets indended the
          -- forementioned length
          Intermediate
y Seq.:< Seq Intermediate
ys ->
            let hd :: Builder
hd = Char -> Builder
B.singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
buildUnwords (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Intermediate -> Seq Builder
go (forall a. [a] -> Seq a
Seq.fromList [Intermediate
initial, Intermediate
y]))
                butLast :: Seq Builder
butLast = Builder
hd forall a. a -> Seq a -> Seq a
Seq.<| forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Builder -> Builder
doIndentOf (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)) (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 (forall atom carrier. SExprPrinter atom carrier -> Int
indentAmount SExprPrinter a (SExpr a)
spec forall a. Num a => a -> a -> a
+ Int
1) -- 1 for '('

    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
" ") 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 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
'(' forall a. Semigroup a => a -> a -> a
<> Builder
x) 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 forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (forall atom carrier. SExprPrinter atom carrier -> Int
indentAmount SExprPrinter a (SExpr a)
spec) Text
" "
          sep :: Builder
sep = String -> Builder
B.fromString String
" . "
      in (forall a. Seq a -> a -> Seq a
Seq.|> (Builder
txtInd forall a. Semigroup a => a -> a -> a
<> Builder
sep forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
t 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 forall a. Seq a -> ViewR a
Seq.viewr Seq Builder
s of
      ViewR Builder
Seq.EmptyR -> forall a. a -> Seq a
Seq.singleton (Char -> Builder
B.singleton Char
')')
      Seq Builder
xs Seq.:> Builder
x -> Seq Builder
xs forall a. Seq a -> a -> Seq a
Seq.|> (Builder
x forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')')

    buildUnwords :: Seq Builder -> Builder
buildUnwords Seq Builder
sq =
      case forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
sq of
      ViewL Builder
Seq.EmptyL -> forall a. Monoid a => a
mempty
      Builder
t Seq.:< Seq Builder
ts -> Builder
t forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (\ Builder
x -> Char -> Builder
B.singleton Char
' ' 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
" . " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
t forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')'

    ppBasic :: Intermediate -> Maybe Builder
ppBasic (IAtom Text
t) = forall a. a -> Maybe a
Just (Text -> Builder
B.fromText Text
t)
    ppBasic (Intermediate
IEmpty) = forall a. a -> Maybe a
Just (String -> Builder
B.fromString String
"()")
    ppBasic Intermediate
_ = forall a. Maybe a
Nothing


-- | Modify the carrier type of a 'SExprPrinter' by describing how
--   to convert the new type back to the previous type. For example,
--   to pretty-print a well-formed s-expression, we can modify the
--   'SExprPrinter' value as follows:
--
-- >>> let printer = setFromCarrier fromWellFormed (basicPrint id)
-- >>> encodeOne printer (WFSList [WFSAtom "ele", WFSAtom "phant"])
-- "(ele phant)"
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 :: c -> SExpr a
fromCarrier = forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
fromCarrier SExprPrinter a b
pr forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> b
fc }


-- | Dictate a maximum width for pretty-printed s-expressions.
--
-- >>> let printer = setMaxWidth 8 (basicPrint id)
-- >>> encodeOne printer (L [A "one", A "two", A "three"])
-- "(one \n  two\n  three)"
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 :: Maybe Int
maxWidth = forall a. a -> Maybe a
Just Int
n }


-- | Allow the serialized s-expression to be arbitrarily wide. This
--   makes all pretty-printing happen on a single line.
--
-- >>> let printer = removeMaxWidth (basicPrint id)
-- >>> encodeOne printer (L [A "one", A "two", A "three"])
-- "(one two three)"
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 :: Maybe Int
maxWidth = forall a. Maybe a
Nothing }


-- | Set the number of spaces that a subsequent line will be indented
--   after a swing indentation.
--
-- >>> let printer = setMaxWidth 12 (basicPrint id)
-- >>> encodeOne printer (L [A "elephant", A "pachyderm"])
-- "(elephant \n  pachyderm)"
-- >>> encodeOne (setIndentAmount 4) (L [A "elephant", A "pachyderm"])
-- "(elephant \n    pachyderm)"
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 :: Int
indentAmount = Int
n }


-- | Dictate how to indent subsequent lines based on the leading
--   subexpression in an s-expression. For details on how this works,
--   consult the documentation of the 'Indent' type.
--
-- >>> let indent (A "def") = SwingAfter 1; indent _ = Swing
-- >>> let printer = setIndentStrategy indent (setMaxWidth 8 (basicPrint id))
-- >>> encodeOne printer (L [ A "def", L [ A "func", A "arg" ], A "body" ])
-- "(def (func arg)\n  body)"
-- >>> encodeOne printer (L [ A "elephant", A "among", A "pachyderms" ])
-- "(elephant \n  among\n  pachyderms)"
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 :: SExpr atom -> Indent
swingIndent = SExpr atom -> Indent
st }


spaceDot :: B.Builder
spaceDot :: Builder
spaceDot = Char -> Builder
B.singleton Char
' ' forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
' '

-- Indents a line by n spaces
indent :: Int -> B.Builder -> B.Builder
indent :: Int -> Builder -> Builder
indent Int
n Builder
ts =
  forall a. Monoid a => [a] -> a
mconcat [ Char -> Builder
B.singleton Char
' ' | Int
_ <- [Int
1..Int
n]] forall a. Semigroup a => a -> a -> a
<> Builder
ts


-- Sort of like 'unlines' but without the trailing newline
joinLinesS :: Seq.Seq B.Builder -> B.Builder
joinLinesS :: Seq Builder -> Builder
joinLinesS Seq Builder
s = case forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
  ViewL Builder
Seq.EmptyL -> Builder
""
  Builder
t Seq.:< Seq Builder
ts
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Seq Builder
ts -> Builder
t
    | Bool
otherwise -> Builder
t forall a. Semigroup a => a -> a -> a
<> String -> Builder
B.fromString String
"\n" forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
joinLinesS Seq Builder
ts


-- Sort of like 'unlines' but without the trailing newline
unwordsS :: Seq.Seq B.Builder -> B.Builder
unwordsS :: Seq Builder -> Builder
unwordsS Seq Builder
s = case forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
  ViewL Builder
Seq.EmptyL -> Builder
""
  Builder
t Seq.:< Seq Builder
ts
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Seq Builder
ts -> Builder
t
    | Bool
otherwise -> Builder
t forall a. Semigroup a => a -> a -> a
<> Builder
" " forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
unwordsS Seq Builder
ts


-- Indents every line n spaces, and adds a newline to the beginning
-- used in swung indents
indentAllS :: Int -> Seq.Seq B.Builder -> B.Builder
indentAllS :: Int -> Seq Builder -> Builder
indentAllS Int
n Seq Builder
s = if forall a. Seq a -> Bool
Seq.null Seq Builder
s
                 then Builder
""
                 else (Builder
"\n" forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ Seq Builder -> Builder
joinLinesS forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Builder -> Builder
indent Int
n) Seq Builder
s

-- Indents every line but the first by some amount
-- used in aligned indents
indentSubsequentS :: Int -> Seq.Seq B.Builder -> B.Builder
indentSubsequentS :: Int -> Seq Builder -> Builder
indentSubsequentS Int
n Seq Builder
s = case forall a. Seq a -> ViewL a
Seq.viewl Seq Builder
s of
  ViewL Builder
Seq.EmptyL -> Builder
""
  Builder
t Seq.:< Seq Builder
ts
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null Seq Builder
ts -> Builder
t
    | Bool
otherwise -> Seq Builder -> Builder
joinLinesS (Builder
t forall a. a -> Seq a -> Seq a
Seq.<| forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Builder -> Builder
indent Int
n) Seq Builder
ts)


-- oh god this code is so disgusting
-- i'm sorry to everyone i let down by writing this
-- i swear i'll do better in the future i promise i have to
-- for my sake and for everyone's

-- | Pretty-print a 'SExpr' according to the options in a
--   'LayoutOptions' value.
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
indentPrint :: Bool
maxWidth :: Maybe Int
indentAmount :: Int
swingIndent :: SExpr a -> Indent
fromCarrier :: SExpr a -> SExpr a
atomPrinter :: a -> Text
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
.. } SExpr a
expr = case Maybe Int
maxWidth of
  Maybe Int
Nothing
    | Bool
indentPrint -> 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 (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  -> 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
indentPrint :: Bool
maxWidth :: Maybe Int
indentAmount :: Int
swingIndent :: SExpr a -> Indent
fromCarrier :: SExpr a -> SExpr a
atomPrinter :: a -> Text
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
.. } = Builder -> Text
B.toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Intermediate -> Builder
pp Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
      -- we always are going to have a head, a (possibly empty) body,
      -- and a (possibly empty) tail in our list formats
      Char -> Builder
B.singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> Builder
hd forall a. Semigroup a => a -> a -> a
<> Builder
body forall a. Semigroup a => a -> a -> a
<> Builder
tl forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton Char
')'
      where
        -- the tail is either nothing, or the final dotted pair
        tl :: Builder
tl = case Maybe Text
end of
               Maybe Text
Nothing -> forall a. Monoid a => a
mempty
               Just Text
x  -> String -> Builder
B.fromString String
" . " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
x
        -- the head is the pretty-printed head, with an ambient
        -- indentation of +1 to account for the left paren
        hd :: Builder
hd = Int -> Intermediate -> Builder
pp (Int
indforall 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) = forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
n Seq Intermediate
values
                  t :: Builder
t  = Seq Builder -> Builder
unwordsS (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp (Int
indforall a. Num a => a -> a -> a
+Int
1forall a. Num a => a -> a -> a
+Int
1)) Seq Intermediate
l) -- 1 for (, 1 for ' '
                  nextInd :: Int
nextInd = Int
ind forall a. Num a => a -> a -> a
+ Int
indentAmount forall a. Num a => a -> a -> a
+ Int
1 -- 1 for (
                  ts :: Builder
ts = Int -> Seq Builder -> Builder
indentAllS Int
nextInd (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
' ' forall a. Semigroup a => a -> a -> a
<> Builder
t forall a. Semigroup a => a -> a -> a
<> Builder
ts
            Indent
Swing ->
              let nextInd :: Int
nextInd = Int
ind forall a. Num a => a -> a -> a
+ Int
indentAmount forall a. Num a => a -> a -> a
+ Int
1 -- 1 for (
              in Int -> Seq Builder -> Builder
indentAllS Int
nextInd (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 forall a. Num a => a -> a -> a
+ Int
headWidth forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Int
1 -- 1 for (, 1 for ' ' below
              in Char -> Builder
B.singleton Char
' ' forall a. Semigroup a => a -> a -> a
<>
                 Int -> Seq Builder -> Builder
indentSubsequentS Int
nextInd (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
          -- if there's nothing here, then we don't have anything to
          -- indent
          | forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Intermediate
values forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
          -- if we can't fit the whole next s-expression on the same
          -- line, then we use the indented form
          | Size -> Int
sizeSum Size
sz forall a. Num a => a -> a -> a
+ Int
ind forall a. Ord a => a -> a -> Bool
> Int
maxAmt = Builder
indented
          | Bool
otherwise =
            -- otherwise we print the whole thing on one line!
            Char -> Builder
B.singleton Char
' ' forall a. Semigroup a => a -> a -> a
<> Seq Builder -> Builder
unwordsS (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Intermediate -> Builder
pp (Int
ind forall a. Num a => a -> a -> a
+ Int
1)) Seq Intermediate
values)


-- if we don't indent anything, then we can ignore a bunch of the
-- details above
flatPrintSExpr :: SExpr Text -> TL.Text
flatPrintSExpr :: SExpr Text -> Text
flatPrintSExpr = Builder -> Text
B.toLazyText 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
'(' forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pHead SExpr Text
x 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
'(' 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
' ' forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pHead SExpr Text
x forall a. Semigroup a => a -> a -> a
<> SExpr Text -> Builder
pTail SExpr Text
xs
    pTail (SAtom Text
t) =
      Builder
spaceDot forall a. Semigroup a => a -> a -> a
<>
      Text -> Builder
B.fromText Text
t forall a. Semigroup a => a -> a -> a
<>
      Char -> Builder
B.singleton Char
')'
    pTail SExpr Text
SNil =
      Char -> Builder
B.singleton Char
')'


-- | Turn a single s-expression into a string according to a given
--   'SExprPrinter'.
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
indentPrint :: Bool
maxWidth :: Maybe Int
indentAmount :: Int
swingIndent :: SExpr atom -> Indent
fromCarrier :: carrier -> SExpr atom
atomPrinter :: atom -> Text
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
.. }) =
  Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
prettyPrintSExpr (SExprPrinter atom carrier
s { fromCarrier :: SExpr atom -> SExpr atom
fromCarrier = forall a. a -> a
id }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. carrier -> SExpr atom
fromCarrier


-- | Turn a list of s-expressions into a single string according to
--   a given 'SExprPrinter'.
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" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOne SExprPrinter atom carrier
spec)


-- | Turn a single s-expression into a lazy 'Text' according to a given
--   'SExprPrinter'.
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
indentPrint :: Bool
maxWidth :: Maybe Int
indentAmount :: Int
swingIndent :: SExpr atom -> Indent
fromCarrier :: carrier -> SExpr atom
atomPrinter :: atom -> Text
indentPrint :: forall atom carrier. SExprPrinter atom carrier -> Bool
maxWidth :: forall atom carrier. SExprPrinter atom carrier -> Maybe Int
indentAmount :: forall atom carrier. SExprPrinter atom carrier -> Int
swingIndent :: forall atom carrier.
SExprPrinter atom carrier -> SExpr atom -> Indent
fromCarrier :: forall atom carrier.
SExprPrinter atom carrier -> carrier -> SExpr atom
atomPrinter :: forall atom carrier. SExprPrinter atom carrier -> atom -> Text
.. }) =
  forall a. SExprPrinter a (SExpr a) -> SExpr a -> Text
prettyPrintSExpr (SExprPrinter atom carrier
s { fromCarrier :: SExpr atom -> SExpr atom
fromCarrier = forall a. a -> a
id }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. carrier -> SExpr atom
fromCarrier


-- | Turn a list of s-expressions into a lazy 'Text' according to
--   a given 'SExprPrinter'.
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" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOneLazy SExprPrinter atom carrier
spec)