{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DoAndIfThenElse            #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE RecordWildCards            #-}
module Language.Haskell.Stylish.Printer
  ( Printer(..)
  , PrinterConfig(..)
  , PrinterState(..)

    -- * Alias
  , P

    -- * Functions to use the printer
  , runPrinter
  , runPrinter_

    -- ** Combinators
  , comma
  , dot
  , getCurrentLine
  , getCurrentLineLength
  , newline
  , parenthesize
  , prefix
  , putComment
  , putMaybeLineComment
  , putOutputable
  , putCond
  , putType
  , putRdrName
  , putText
  , sep
  , space
  , spaces
  , suffix
  , pad

    -- ** Advanced combinators
  , withColumns
  , modifyCurrentLine
  , wrapping
  ) where

--------------------------------------------------------------------------------
import           Prelude                         hiding (lines)

--------------------------------------------------------------------------------
import qualified GHC.Hs                          as GHC
import           GHC.Hs.Extension                (GhcPs)
import           GHC.Types.Name.Reader           (RdrName (..))
import           GHC.Types.SrcLoc                (GenLocated (..))
import qualified GHC.Types.SrcLoc                as GHC
import           GHC.Utils.Outputable            (Outputable)

--------------------------------------------------------------------------------
import           Control.Monad                   (forM_, replicateM_)
import           Control.Monad.Reader            (MonadReader, ReaderT (..),
                                                  asks, local)
import           Control.Monad.State             (MonadState, State, get, gets,
                                                  modify, put, runState)
import           Data.List                       (foldl')

--------------------------------------------------------------------------------
import           Language.Haskell.Stylish.GHC    (showOutputable)
import           Language.Haskell.Stylish.Module (Lines)

-- | Shorthand for 'Printer' monad
type P = Printer

-- | Printer that keeps state of file
newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a)
  deriving (Functor Printer
forall a. a -> Printer a
forall a b. Printer a -> Printer b -> Printer a
forall a b. Printer a -> Printer b -> Printer b
forall a b. Printer (a -> b) -> Printer a -> Printer b
forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Printer a -> Printer b -> Printer a
$c<* :: forall a b. Printer a -> Printer b -> Printer a
*> :: forall a b. Printer a -> Printer b -> Printer b
$c*> :: forall a b. Printer a -> Printer b -> Printer b
liftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
$cliftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
$c<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
pure :: forall a. a -> Printer a
$cpure :: forall a. a -> Printer a
Applicative, forall a b. a -> Printer b -> Printer a
forall a b. (a -> b) -> Printer a -> Printer b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Printer b -> Printer a
$c<$ :: forall a b. a -> Printer b -> Printer a
fmap :: forall a b. (a -> b) -> Printer a -> Printer b
$cfmap :: forall a b. (a -> b) -> Printer a -> Printer b
Functor, Applicative Printer
forall a. a -> Printer a
forall a b. Printer a -> Printer b -> Printer b
forall a b. Printer a -> (a -> Printer b) -> Printer b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Printer a
$creturn :: forall a. a -> Printer a
>> :: forall a b. Printer a -> Printer b -> Printer b
$c>> :: forall a b. Printer a -> Printer b -> Printer b
>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
$c>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
Monad, MonadReader PrinterConfig, MonadState PrinterState)

-- | Configuration for printer, currently empty
data PrinterConfig = PrinterConfig
    { PrinterConfig -> Maybe Int
columns :: !(Maybe Int)
    }

-- | State of printer
data PrinterState = PrinterState
  { PrinterState -> Lines
lines       :: !Lines
  , PrinterState -> Int
linePos     :: !Int
  , PrinterState -> String
currentLine :: !String
  }

-- | Run printer to get printed lines out of module as well as return value of monad
runPrinter :: PrinterConfig -> Printer a -> (a, Lines)
runPrinter :: forall a. PrinterConfig -> Printer a -> (a, Lines)
runPrinter PrinterConfig
cfg (Printer ReaderT PrinterConfig (State PrinterState) a
printer) =
  let
    (a
a, PrinterState Lines
parsedLines Int
_ String
startedLine) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PrinterConfig (State PrinterState) a
printer PrinterConfig
cfg forall s a. State s a -> s -> (a, s)
`runState` Lines -> Int -> String -> PrinterState
PrinterState [] Int
0 String
""
  in
    (a
a, Lines
parsedLines forall a. Semigroup a => a -> a -> a
<> if String
startedLine forall a. Eq a => a -> a -> Bool
== [] then [] else [String
startedLine])

-- | Run printer to get printed lines only
runPrinter_ :: PrinterConfig -> Printer a -> Lines
runPrinter_ :: forall a. PrinterConfig -> Printer a -> Lines
runPrinter_ PrinterConfig
cfg Printer a
printer = forall a b. (a, b) -> b
snd (forall a. PrinterConfig -> Printer a -> (a, Lines)
runPrinter PrinterConfig
cfg Printer a
printer)

-- | Print text
putText :: String -> P ()
putText :: String -> Printer ()
putText String
txt = do
  String
l <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> String
currentLine
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \PrinterState
s -> PrinterState
s { currentLine :: String
currentLine = String
l forall a. Semigroup a => a -> a -> a
<> String
txt }

-- | Check condition post action, and use fallback if false
putCond :: (PrinterState -> Bool) -> P b -> P b -> P b
putCond :: forall b. (PrinterState -> Bool) -> P b -> P b -> P b
putCond PrinterState -> Bool
p P b
action P b
fallback = do
  PrinterState
prevState <- forall s (m :: * -> *). MonadState s m => m s
get
  b
res <- P b
action
  PrinterState
currState <- forall s (m :: * -> *). MonadState s m => m s
get
  if PrinterState -> Bool
p PrinterState
currState then forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
  else forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
prevState forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P b
fallback

-- | Print an 'Outputable'
putOutputable :: Outputable a => a -> P ()
putOutputable :: forall a. Outputable a => a -> Printer ()
putOutputable = String -> Printer ()
putText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> String
showOutputable

-- | Put all comments that has positions within 'SrcSpan' and separate by
--   passed @P ()@
{-
putAllSpanComments :: P () -> SrcSpan -> P ()
putAllSpanComments suff = \case
  UnhelpfulSpan _ -> pure ()
  RealSrcSpan rspan -> do
    cmts <- removeComments \(L rloc _) ->
      srcSpanStartLine rloc >= srcSpanStartLine rspan &&
      srcSpanEndLine rloc <= srcSpanEndLine rspan

    forM_ cmts (\c -> putComment c >> suff)
-}

-- | Print any comment
putComment :: GHC.EpaComment -> P ()
putComment :: EpaComment -> Printer ()
putComment EpaComment
epaComment = case EpaComment -> EpaCommentTok
GHC.ac_tok EpaComment
epaComment of
  GHC.EpaDocComment HsDocString
hs  -> String -> Printer ()
putText forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show HsDocString
hs
  GHC.EpaLineComment String
s  -> String -> Printer ()
putText String
s
  GHC.EpaDocOptions String
s   -> String -> Printer ()
putText String
s
  GHC.EpaBlockComment String
s -> String -> Printer ()
putText String
s
  EpaCommentTok
GHC.EpaEofComment     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

putMaybeLineComment :: Maybe GHC.EpaComment -> P ()
putMaybeLineComment :: Maybe EpaComment -> Printer ()
putMaybeLineComment = \case
    Maybe EpaComment
Nothing  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just EpaComment
cmt -> Printer ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EpaComment -> Printer ()
putComment EpaComment
cmt

-- | Print a 'RdrName'
putRdrName :: GenLocated GHC.SrcSpanAnnN RdrName -> P ()
putRdrName :: GenLocated SrcSpanAnnN RdrName -> Printer ()
putRdrName GenLocated SrcSpanAnnN RdrName
rdrName = case forall l e. GenLocated l e -> e
GHC.unLoc GenLocated SrcSpanAnnN RdrName
rdrName of
    Unqual OccName
name -> do
      let (String
pre, String
post) = [NameAnn] -> (String, String)
nameAnnAdornments forall a b. (a -> b) -> a -> b
$
            forall a. EpAnn a -> [a]
GHC.epAnnAnnsL forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> a
GHC.ann forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> l
GHC.getLoc GenLocated SrcSpanAnnN RdrName
rdrName
      String -> Printer ()
putText String
pre
      String -> Printer ()
putText (forall a. Outputable a => a -> String
showOutputable OccName
name)
      String -> Printer ()
putText String
post
    Qual ModuleName
modulePrefix OccName
name ->
      ModuleName -> Printer ()
putModuleName ModuleName
modulePrefix forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
dot forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Printer ()
putText (forall a. Outputable a => a -> String
showOutputable OccName
name)
    Orig Module
_ OccName
name ->
      String -> Printer ()
putText (forall a. Outputable a => a -> String
showOutputable OccName
name)
    Exact Name
name ->
      String -> Printer ()
putText (forall a. Outputable a => a -> String
showOutputable Name
name)

nameAnnAdornments :: [GHC.NameAnn] -> (String, String)
nameAnnAdornments :: [NameAnn] -> (String, String)
nameAnnAdornments = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    (\(String
accl, String
accr) NameAnn
nameAnn ->
        let (String
l, String
r) = NameAnn -> (String, String)
nameAnnAdornment NameAnn
nameAnn in (String
accl forall a. [a] -> [a] -> [a]
++ String
l, String
r forall a. [a] -> [a] -> [a]
++ String
accr))
    (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)

nameAnnAdornment :: GHC.NameAnn -> (String, String)
nameAnnAdornment :: NameAnn -> (String, String)
nameAnnAdornment = \case
    GHC.NameAnn {[TrailingAnn]
EpaLocation
NameAdornment
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_name :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
nann_trailing :: [TrailingAnn]
nann_close :: EpaLocation
nann_name :: EpaLocation
nann_open :: EpaLocation
nann_adornment :: NameAdornment
..}       -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnCommas {[EpaLocation]
[TrailingAnn]
EpaLocation
NameAdornment
nann_commas :: NameAnn -> [EpaLocation]
nann_trailing :: [TrailingAnn]
nann_close :: EpaLocation
nann_commas :: [EpaLocation]
nann_open :: EpaLocation
nann_adornment :: NameAdornment
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
..} -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnBars {[EpaLocation]
[TrailingAnn]
EpaLocation
NameAdornment
nann_bars :: NameAnn -> [EpaLocation]
nann_trailing :: [TrailingAnn]
nann_close :: EpaLocation
nann_bars :: [EpaLocation]
nann_open :: EpaLocation
nann_adornment :: NameAdornment
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
..}   -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnOnly {[TrailingAnn]
EpaLocation
NameAdornment
nann_trailing :: [TrailingAnn]
nann_close :: EpaLocation
nann_open :: EpaLocation
nann_adornment :: NameAdornment
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
..}   -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnRArrow {}   -> (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
    GHC.NameAnnQuote {}    -> (String
"'", forall a. Monoid a => a
mempty)
    GHC.NameAnnTrailing {} -> (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
  where
    fromAdornment :: NameAdornment -> (String, String)
fromAdornment NameAdornment
GHC.NameParens     = (String
"(", String
")")
    fromAdornment NameAdornment
GHC.NameBackquotes = (String
"`", String
"`")
    fromAdornment NameAdornment
GHC.NameParensHash = (String
"#(", String
"#)")
    fromAdornment NameAdornment
GHC.NameSquare     = (String
"[", String
"]")

-- | Print module name
putModuleName :: GHC.ModuleName -> P ()
putModuleName :: ModuleName -> Printer ()
putModuleName = String -> Printer ()
putText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
GHC.moduleNameString

-- | Print type
putType :: GHC.LHsType GhcPs -> P ()
putType :: LHsType GhcPs -> Printer ()
putType LHsType GhcPs
ltp = case forall l e. GenLocated l e -> e
GHC.unLoc LHsType GhcPs
ltp of
  GHC.HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
arrowTp LHsType GhcPs
argTp LHsType GhcPs
funTp -> do
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
argTp
    Printer ()
space
    case HsArrow GhcPs
arrowTp of
        GHC.HsUnrestrictedArrow {} -> String -> Printer ()
putText String
"->"
        GHC.HsLinearArrow {}       -> String -> Printer ()
putText String
"%1 ->"
        GHC.HsExplicitMult {}      -> forall a. Outputable a => a -> Printer ()
putOutputable HsArrow GhcPs
arrowTp
    Printer ()
space
    LHsType GhcPs -> Printer ()
putType LHsType GhcPs
funTp
  GHC.HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t1 LHsType GhcPs
t2 ->
    LHsType GhcPs -> Printer ()
putType LHsType GhcPs
t1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LHsType GhcPs -> Printer ()
putType LHsType GhcPs
t2
  GHC.HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
_ [LHsType GhcPs]
xs -> do
    String -> Printer ()
putText String
"'["
    forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Printer ()
putType [LHsType GhcPs]
xs)
    String -> Printer ()
putText String
"]"
  GHC.HsExplicitTupleTy XExplicitTupleTy GhcPs
_ [LHsType GhcPs]
xs -> do
    String -> Printer ()
putText String
"'("
    forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Printer ()
putType [LHsType GhcPs]
xs)
    String -> Printer ()
putText String
")"
  GHC.HsOpTy XOpTy GhcPs
_ PromotionFlag
_ LHsType GhcPs
lhs LIdP GhcPs
op LHsType GhcPs
rhs -> do
    LHsType GhcPs -> Printer ()
putType LHsType GhcPs
lhs
    Printer ()
space
    GenLocated SrcSpanAnnN RdrName -> Printer ()
putRdrName LIdP GhcPs
op
    Printer ()
space
    LHsType GhcPs -> Printer ()
putType LHsType GhcPs
rhs
  GHC.HsTyVar XTyVar GhcPs
_ PromotionFlag
flag LIdP GhcPs
rdrName -> do
    case PromotionFlag
flag of
      PromotionFlag
GHC.IsPromoted  -> String -> Printer ()
putText String
"'"
      PromotionFlag
GHC.NotPromoted -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    GenLocated SrcSpanAnnN RdrName -> Printer ()
putRdrName LIdP GhcPs
rdrName
  GHC.HsTyLit XTyLit GhcPs
_ HsTyLit GhcPs
tp ->
    forall a. Outputable a => a -> Printer ()
putOutputable HsTyLit GhcPs
tp
  GHC.HsParTy XParTy GhcPs
_ LHsType GhcPs
tp -> do
    String -> Printer ()
putText String
"("
    LHsType GhcPs -> Printer ()
putType LHsType GhcPs
tp
    String -> Printer ()
putText String
")"
  GHC.HsTupleTy XTupleTy GhcPs
_ HsTupleSort
_ [LHsType GhcPs]
xs -> do
    String -> Printer ()
putText String
"("
    forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Printer ()
putType [LHsType GhcPs]
xs)
    String -> Printer ()
putText String
")"
  GHC.HsForAllTy {} ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsQualTy {} ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsAppKindTy XAppKindTy GhcPs
_ LHsType GhcPs
_ LHsType GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsListTy XListTy GhcPs
_ LHsType GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsSumTy XSumTy GhcPs
_ [LHsType GhcPs]
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsIParamTy XIParamTy GhcPs
_ XRec GhcPs HsIPName
_ LHsType GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsKindSig XKindSig GhcPs
_ LHsType GhcPs
_ LHsType GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsStarTy XStarTy GhcPs
_ Bool
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsSpliceTy XSpliceTy GhcPs
_ HsUntypedSplice GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsDocTy XDocTy GhcPs
_ LHsType GhcPs
_ LHsDoc GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsBangTy XBangTy GhcPs
_ HsSrcBang
_ LHsType GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.HsWildCardTy XWildCardTy GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp
  GHC.XHsType XXType GhcPs
_ ->
    forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
ltp

-- | Print a newline
newline :: P ()
newline :: Printer ()
newline = do
  String
l <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> String
currentLine
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \PrinterState
s -> PrinterState
s { currentLine :: String
currentLine = String
"", linePos :: Int
linePos = Int
0, lines :: Lines
lines = PrinterState -> Lines
lines PrinterState
s forall a. Semigroup a => a -> a -> a
<> [String
l] }

-- | Print a space
space :: P ()
space :: Printer ()
space = String -> Printer ()
putText String
" "

-- | Print a number of spaces
spaces :: Int -> P ()
spaces :: Int -> Printer ()
spaces Int
i = forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
i Printer ()
space

-- | Print a dot
dot :: P ()
dot :: Printer ()
dot = String -> Printer ()
putText String
"."

-- | Print a comma
comma :: P ()
comma :: Printer ()
comma = String -> Printer ()
putText String
","

-- | Add parens around a printed action
parenthesize :: P a -> P a
parenthesize :: forall a. P a -> P a
parenthesize P a
action = String -> Printer ()
putText String
"(" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
action forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Printer ()
putText String
")"

-- | Add separator between each element of the given printers
sep :: P a -> [P a] -> P ()
sep :: forall a. P a -> [P a] -> Printer ()
sep P a
_ []             = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sep P a
s (P a
first : [P a]
rest) = P a
first forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [P a]
rest (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) P a
s)

-- | Prefix a printer with another one
prefix :: P a -> P b -> P b
prefix :: forall a b. Printer a -> Printer b -> Printer b
prefix P a
pa P b
pb = P a
pa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P b
pb

-- | Suffix a printer with another one
suffix :: P a -> P b -> P a
suffix :: forall a b. Printer a -> Printer b -> Printer a
suffix P a
pa P b
pb = P b
pb forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P a
pa

-- | Indent to a given number of spaces.  If the current line already exceeds
-- that number in length, nothing happens.
pad :: Int -> P ()
pad :: Int -> Printer ()
pad Int
n = do
    Int
len <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P String
getCurrentLine
    Int -> Printer ()
spaces forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Int
len

-- | Get current line
getCurrentLine :: P String
getCurrentLine :: P String
getCurrentLine = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> String
currentLine

-- | Get current line length
getCurrentLineLength :: P Int
getCurrentLineLength :: Printer Int
getCurrentLineLength = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Int
length P String
getCurrentLine

modifyCurrentLine :: (String -> String) -> P ()
modifyCurrentLine :: (String -> String) -> Printer ()
modifyCurrentLine String -> String
f = do
    PrinterState
s0 <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
s0 {currentLine :: String
currentLine = String -> String
f forall a b. (a -> b) -> a -> b
$ PrinterState -> String
currentLine PrinterState
s0}

wrapping
    :: P a  -- ^ First printer to run
    -> P a  -- ^ Printer to run if first printer violates max columns
    -> P a  -- ^ Result of either the first or the second printer
wrapping :: forall a. P a -> P a -> P a
wrapping P a
p1 P a
p2 = do
    Maybe Int
maxCols <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrinterConfig -> Maybe Int
columns
    case Maybe Int
maxCols of
        -- No wrapping
        Maybe Int
Nothing -> P a
p1
        Just Int
c  -> do
            PrinterState
s0 <- forall s (m :: * -> *). MonadState s m => m s
get
            a
x <- P a
p1
            PrinterState
s1 <- forall s (m :: * -> *). MonadState s m => m s
get
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrinterState -> String
currentLine PrinterState
s1) forall a. Ord a => a -> a -> Bool
<= Int
c
                -- No need to wrap
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                else do
                    forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
s0
                    a
y <- P a
p2
                    PrinterState
s2 <- forall s (m :: * -> *). MonadState s m => m s
get
                    if forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrinterState -> String
currentLine PrinterState
s1) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrinterState -> String
currentLine PrinterState
s2)
                        -- Wrapping didn't help!
                        then forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
s1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                        -- Wrapped
                        else forall (f :: * -> *) a. Applicative f => a -> f a
pure a
y

withColumns :: Maybe Int -> P a -> P a
withColumns :: forall a. Maybe Int -> P a -> P a
withColumns Maybe Int
c = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \PrinterConfig
pc -> PrinterConfig
pc {columns :: Maybe Int
columns = Maybe Int
c}