{-# 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 qualified GHC.Types.Basic                 as GHC
import           GHC.Types.Name.Reader           (RdrName (..))
import           GHC.Types.SrcLoc                (GenLocated (..))
import qualified GHC.Types.SrcLoc                as GHC
import qualified GHC.Unit.Module.Name            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
tp ->
    forall a. Outputable a => a -> Printer ()
putOutputable HsTyLit
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
_ HsSplice 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}