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

    -- * Alias
  , P

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

    -- ** Combinators
  , comma
  , dot
  , getAnnot
  , getCurrentLine
  , getCurrentLineLength
  , getDocstrPrev
  , newline
  , parenthesize
  , peekNextCommentPos
  , prefix
  , putComment
  , putEolComment
  , putOutputable
  , putAllSpanComments
  , putCond
  , putType
  , putRdrName
  , putText
  , removeCommentTo
  , removeCommentToEnd
  , removeLineComment
  , sep
  , groupAttachedComments
  , groupWithoutComments
  , space
  , spaces
  , suffix
  , pad

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

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

--------------------------------------------------------------------------------
import           ApiAnnotation                   (AnnKeywordId(..), AnnotationComment(..))
import           BasicTypes                      (PromotionFlag(..))
import           GHC.Hs.Extension                (GhcPs, NoExtField(..))
import           GHC.Hs.Types                    (HsType(..))
import           Module                          (ModuleName, moduleNameString)
import           RdrName                         (RdrName(..))
import           SrcLoc                          (GenLocated(..), RealLocated)
import           SrcLoc                          (Located, SrcSpan(..))
import           SrcLoc                          (srcSpanStartLine, srcSpanEndLine)
import           Outputable                      (Outputable)

--------------------------------------------------------------------------------
import           Control.Monad                   (forM_, replicateM_)
import           Control.Monad.Reader            (MonadReader, ReaderT(..), asks, local)
import           Control.Monad.State             (MonadState, State)
import           Control.Monad.State             (runState)
import           Control.Monad.State             (get, gets, modify, put)
import           Data.Foldable                   (find, toList)
import           Data.Functor                    ((<&>))
import           Data.List                       (delete, isPrefixOf)
import           Data.List.NonEmpty              (NonEmpty(..))

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

-- | 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
a -> Printer a
Functor Printer
-> (forall a. a -> Printer a)
-> (forall a b. Printer (a -> b) -> Printer a -> Printer b)
-> (forall a b c.
    (a -> b -> c) -> Printer a -> Printer b -> Printer c)
-> (forall a b. Printer a -> Printer b -> Printer b)
-> (forall a b. Printer a -> Printer b -> Printer a)
-> Applicative Printer
Printer a -> Printer b -> Printer b
Printer a -> Printer b -> Printer a
Printer (a -> b) -> Printer a -> Printer b
(a -> b -> c) -> Printer a -> Printer b -> Printer c
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
<* :: Printer a -> Printer b -> Printer a
$c<* :: forall a b. Printer a -> Printer b -> Printer a
*> :: Printer a -> Printer b -> Printer b
$c*> :: forall a b. Printer a -> Printer b -> Printer b
liftA2 :: (a -> b -> c) -> Printer a -> Printer b -> Printer c
$cliftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
<*> :: Printer (a -> b) -> Printer a -> Printer b
$c<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
pure :: a -> Printer a
$cpure :: forall a. a -> Printer a
$cp1Applicative :: Functor Printer
Applicative, a -> Printer b -> Printer a
(a -> b) -> Printer a -> Printer b
(forall a b. (a -> b) -> Printer a -> Printer b)
-> (forall a b. a -> Printer b -> Printer a) -> Functor Printer
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
<$ :: a -> Printer b -> Printer a
$c<$ :: forall a b. a -> Printer b -> Printer a
fmap :: (a -> b) -> Printer a -> Printer b
$cfmap :: forall a b. (a -> b) -> Printer a -> Printer b
Functor, Applicative Printer
a -> Printer a
Applicative Printer
-> (forall a b. Printer a -> (a -> Printer b) -> Printer b)
-> (forall a b. Printer a -> Printer b -> Printer b)
-> (forall a. a -> Printer a)
-> Monad Printer
Printer a -> (a -> Printer b) -> Printer b
Printer a -> Printer b -> Printer b
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 :: a -> Printer a
$creturn :: forall a. a -> Printer a
>> :: Printer a -> Printer b -> Printer b
$c>> :: forall a b. Printer a -> Printer b -> Printer b
>>= :: Printer a -> (a -> Printer b) -> Printer b
$c>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
$cp1Monad :: Applicative Printer
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
  , PrinterState -> [RealLocated AnnotationComment]
pendingComments :: ![RealLocated AnnotationComment]
  , PrinterState -> Module
parsedModule :: !Module
  }

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

-- | Run printer to get printed lines only
runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines
runPrinter_ :: PrinterConfig
-> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines
runPrinter_ PrinterConfig
cfg [RealLocated AnnotationComment]
comments Module
m Printer a
printer = (a, Lines) -> Lines
forall a b. (a, b) -> b
snd (PrinterConfig
-> [RealLocated AnnotationComment]
-> Module
-> Printer a
-> (a, Lines)
forall a.
PrinterConfig
-> [RealLocated AnnotationComment]
-> Module
-> Printer a
-> (a, Lines)
runPrinter PrinterConfig
cfg [RealLocated AnnotationComment]
comments Module
m Printer a
printer)

-- | Print text
putText :: String -> P ()
putText :: String -> Printer ()
putText String
txt = do
  String
l <- (PrinterState -> String) -> Printer String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> String
currentLine
  (PrinterState -> PrinterState) -> Printer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \PrinterState
s -> PrinterState
s { currentLine :: String
currentLine = String
l String -> String -> String
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 :: (PrinterState -> Bool) -> P b -> P b -> P b
putCond PrinterState -> Bool
p P b
action P b
fallback = do
  PrinterState
prevState <- Printer PrinterState
forall s (m :: * -> *). MonadState s m => m s
get
  b
res <- P b
action
  PrinterState
currState <- Printer PrinterState
forall s (m :: * -> *). MonadState s m => m s
get
  if PrinterState -> Bool
p PrinterState
currState then b -> P b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
  else PrinterState -> Printer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
prevState Printer () -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P b
fallback

-- | Print an 'Outputable'
putOutputable :: Outputable a => a -> P ()
putOutputable :: a -> Printer ()
putOutputable = String -> Printer ()
putText (String -> Printer ()) -> (a -> String) -> a -> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 :: Printer () -> SrcSpan -> Printer ()
putAllSpanComments Printer ()
suff = \case
  UnhelpfulSpan FastString
_ -> () -> Printer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  RealSrcSpan RealSrcSpan
rspan -> do
    [AnnotationComment]
cmts <- (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment]
removeComments \(L RealSrcSpan
rloc AnnotationComment
_) ->
      RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rspan Bool -> Bool -> Bool
&&
      RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rloc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rspan

    [AnnotationComment]
-> (AnnotationComment -> Printer ()) -> Printer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnnotationComment]
cmts (\AnnotationComment
c -> AnnotationComment -> Printer ()
putComment AnnotationComment
c Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
suff)

-- | Print any comment
putComment :: AnnotationComment -> P ()
putComment :: AnnotationComment -> Printer ()
putComment = \case
  AnnLineComment String
s -> String -> Printer ()
putText String
s
  AnnDocCommentNext String
s -> String -> Printer ()
putText String
s
  AnnDocCommentPrev String
s -> String -> Printer ()
putText String
s
  AnnDocCommentNamed String
s -> String -> Printer ()
putText String
s
  AnnDocSection Int
_ String
s -> String -> Printer ()
putText String
s
  AnnDocOptions String
s -> String -> Printer ()
putText String
s
  AnnBlockComment String
s -> String -> Printer ()
putText String
s

-- | Given the current start line of 'SrcSpan', remove and put EOL comment for same line
putEolComment :: SrcSpan -> P ()
putEolComment :: SrcSpan -> Printer ()
putEolComment = \case
  RealSrcSpan RealSrcSpan
rspan -> do
    Maybe AnnotationComment
cmt <- (RealLocated AnnotationComment -> Bool)
-> P (Maybe AnnotationComment)
removeComment \case
      L RealSrcSpan
rloc (AnnLineComment String
s) ->
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
          [ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rspan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc
          , Bool -> Bool
not (String
"-- ^" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s)
          , Bool -> Bool
not (String
"-- |" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s)
          ]
      RealLocated AnnotationComment
_ -> Bool
False
    Maybe AnnotationComment
-> (AnnotationComment -> Printer ()) -> Printer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe AnnotationComment
cmt (\AnnotationComment
c -> Printer ()
space Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AnnotationComment -> Printer ()
putComment AnnotationComment
c)
  UnhelpfulSpan FastString
_ -> () -> Printer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Print a 'RdrName'
putRdrName :: Located RdrName -> P ()
putRdrName :: Located RdrName -> Printer ()
putRdrName (L SrcSpan
pos RdrName
n) = case RdrName
n of
  Unqual OccName
name -> do
    [AnnKeywordId]
annots <- SrcSpan -> P [AnnKeywordId]
getAnnot SrcSpan
pos
    if AnnKeywordId
AnnOpenP AnnKeywordId -> [AnnKeywordId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnnKeywordId]
annots then do
      String -> Printer ()
putText String
"("
      String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
      String -> Printer ()
putText String
")"
    else if AnnKeywordId
AnnBackquote AnnKeywordId -> [AnnKeywordId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnnKeywordId]
annots then do
      String -> Printer ()
putText String
"`"
      String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
      String -> Printer ()
putText String
"`"
    else if AnnKeywordId
AnnSimpleQuote AnnKeywordId -> [AnnKeywordId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnnKeywordId]
annots then do
      String -> Printer ()
putText String
"'"
      String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
    else
      String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
  Qual ModuleName
modulePrefix OccName
name ->
    ModuleName -> Printer ()
putModuleName ModuleName
modulePrefix Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
dot Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
  Orig Module
_ OccName
name ->
    String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
  Exact Name
name ->
    String -> Printer ()
putText (Name -> String
forall a. Outputable a => a -> String
showOutputable Name
name)

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

-- | Print type
putType :: Located (HsType GhcPs) -> P ()
putType :: Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
ltp = case Located (HsType GhcPs) -> HsType GhcPs
forall a. Located a -> a
unLocated Located (HsType GhcPs)
ltp of
  HsFunTy XFunTy GhcPs
NoExtField Located (HsType GhcPs)
argTp Located (HsType GhcPs)
funTp -> do
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
argTp
    Printer ()
space
    String -> Printer ()
putText String
"->"
    Printer ()
space
    Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
funTp
  HsAppTy XAppTy GhcPs
NoExtField Located (HsType GhcPs)
t1 Located (HsType GhcPs)
t2 ->
    Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
t1 Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
t2
  HsExplicitListTy XExplicitListTy GhcPs
NoExtField PromotionFlag
_ [Located (HsType GhcPs)]
xs -> do
    String -> Printer ()
putText String
"'["
    Printer () -> [Printer ()] -> Printer ()
forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((Located (HsType GhcPs) -> Printer ())
-> [Located (HsType GhcPs)] -> [Printer ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located (HsType GhcPs) -> Printer ()
putType [Located (HsType GhcPs)]
xs)
    String -> Printer ()
putText String
"]"
  HsExplicitTupleTy XExplicitTupleTy GhcPs
NoExtField [Located (HsType GhcPs)]
xs -> do
    String -> Printer ()
putText String
"'("
    Printer () -> [Printer ()] -> Printer ()
forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((Located (HsType GhcPs) -> Printer ())
-> [Located (HsType GhcPs)] -> [Printer ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located (HsType GhcPs) -> Printer ()
putType [Located (HsType GhcPs)]
xs)
    String -> Printer ()
putText String
")"
  HsOpTy XOpTy GhcPs
NoExtField Located (HsType GhcPs)
lhs Located (IdP GhcPs)
op Located (HsType GhcPs)
rhs -> do
    Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
lhs
    Printer ()
space
    Located RdrName -> Printer ()
putRdrName Located (IdP GhcPs)
Located RdrName
op
    Printer ()
space
    Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
rhs
  HsTyVar XTyVar GhcPs
NoExtField PromotionFlag
flag Located (IdP GhcPs)
rdrName -> do
    case PromotionFlag
flag of
      PromotionFlag
IsPromoted  -> String -> Printer ()
putText String
"'"
      PromotionFlag
NotPromoted -> () -> Printer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Located RdrName -> Printer ()
putRdrName Located (IdP GhcPs)
Located RdrName
rdrName
  HsTyLit XTyLit GhcPs
_ HsTyLit
tp ->
    HsTyLit -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable HsTyLit
tp
  HsParTy XParTy GhcPs
_ Located (HsType GhcPs)
tp -> do
    String -> Printer ()
putText String
"("
    Located (HsType GhcPs) -> Printer ()
putType Located (HsType GhcPs)
tp
    String -> Printer ()
putText String
")"
  HsTupleTy XTupleTy GhcPs
NoExtField HsTupleSort
_ [Located (HsType GhcPs)]
xs -> do
    String -> Printer ()
putText String
"("
    Printer () -> [Printer ()] -> Printer ()
forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma Printer () -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((Located (HsType GhcPs) -> Printer ())
-> [Located (HsType GhcPs)] -> [Printer ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located (HsType GhcPs) -> Printer ()
putType [Located (HsType GhcPs)]
xs)
    String -> Printer ()
putText String
")"
  HsForAllTy XForAllTy GhcPs
NoExtField ForallVisFlag
_ [LHsTyVarBndr GhcPs]
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsQualTy XQualTy GhcPs
NoExtField LHsContext GhcPs
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsAppKindTy XAppKindTy GhcPs
_ Located (HsType GhcPs)
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsListTy XListTy GhcPs
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsSumTy XSumTy GhcPs
_ [Located (HsType GhcPs)]
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsIParamTy XIParamTy GhcPs
_ Located HsIPName
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsKindSig XKindSig GhcPs
_ Located (HsType GhcPs)
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsStarTy XStarTy GhcPs
_ Bool
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsSpliceTy XSpliceTy GhcPs
_ HsSplice GhcPs
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsDocTy XDocTy GhcPs
_ Located (HsType GhcPs)
_ LHsDocString
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsBangTy XBangTy GhcPs
_ HsSrcBang
_ Located (HsType GhcPs)
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  HsWildCardTy XWildCardTy GhcPs
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp
  XHsType XXType GhcPs
_ ->
    Located (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable Located (HsType GhcPs)
ltp

-- | Get a docstring on the start line of 'SrcSpan' that is a @-- ^@ comment
getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment)
getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment)
getDocstrPrev = \case
  UnhelpfulSpan FastString
_ -> Maybe AnnotationComment -> P (Maybe AnnotationComment)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AnnotationComment
forall a. Maybe a
Nothing
  RealSrcSpan RealSrcSpan
rspan -> do
    (RealLocated AnnotationComment -> Bool)
-> P (Maybe AnnotationComment)
removeComment \case
      L RealSrcSpan
rloc (AnnLineComment String
s) ->
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
          [ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rspan Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc
          , String
"-- ^" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
          ]
      RealLocated AnnotationComment
_ -> Bool
False

-- | Print a newline
newline :: P ()
newline :: Printer ()
newline = do
  String
l <- (PrinterState -> String) -> Printer String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> String
currentLine
  (PrinterState -> PrinterState) -> Printer ()
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 Lines -> Lines -> Lines
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 = Int -> Printer () -> Printer ()
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 :: P a -> P a
parenthesize P a
action = String -> Printer ()
putText String
"(" Printer () -> P a -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
action P a -> Printer () -> P a
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 :: P a -> [P a] -> Printer ()
sep P a
_ [] = () -> Printer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sep P a
s (P a
first : [P a]
rest) = P a
first P a -> Printer () -> Printer ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [P a] -> (P a -> P a) -> Printer ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [P a]
rest (P a -> P a -> P a
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 :: P a -> P b -> P b
prefix P a
pa P b
pb = P a
pa P a -> P b -> P b
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 :: P a -> P b -> P a
suffix P a
pa P b
pb = P b
pb P b -> P a -> P a
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 <- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> Printer String -> Printer Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Printer String
getCurrentLine
    Int -> Printer ()
spaces (Int -> Printer ()) -> Int -> Printer ()
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len

-- | Gets comment on supplied 'line' and removes it from the state
removeLineComment :: Int -> P (Maybe AnnotationComment)
removeLineComment :: Int -> P (Maybe AnnotationComment)
removeLineComment Int
line =
  (RealLocated AnnotationComment -> Bool)
-> P (Maybe AnnotationComment)
removeComment (\(L RealSrcSpan
rloc AnnotationComment
_) -> RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line)

-- | Removes comments from the state up to start line of 'SrcSpan' and returns
--   the ones that were removed
removeCommentTo :: SrcSpan -> P [AnnotationComment]
removeCommentTo :: SrcSpan -> P [AnnotationComment]
removeCommentTo = \case
  UnhelpfulSpan FastString
_ -> [AnnotationComment] -> P [AnnotationComment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  RealSrcSpan RealSrcSpan
rspan -> Int -> P [AnnotationComment]
removeCommentTo' (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rspan)

-- | Removes comments from the state up to end line of 'SrcSpan' and returns
--   the ones that were removed
removeCommentToEnd :: SrcSpan -> P [AnnotationComment]
removeCommentToEnd :: SrcSpan -> P [AnnotationComment]
removeCommentToEnd = \case
  UnhelpfulSpan FastString
_ -> [AnnotationComment] -> P [AnnotationComment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  RealSrcSpan RealSrcSpan
rspan -> Int -> P [AnnotationComment]
removeCommentTo' (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rspan)

-- | Removes comments to the line number given and returns the ones removed
removeCommentTo' :: Int -> P [AnnotationComment]
removeCommentTo' :: Int -> P [AnnotationComment]
removeCommentTo' Int
line =
  (RealLocated AnnotationComment -> Bool)
-> P (Maybe AnnotationComment)
removeComment (\(L RealSrcSpan
rloc AnnotationComment
_) -> RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
line) P (Maybe AnnotationComment)
-> (Maybe AnnotationComment -> P [AnnotationComment])
-> P [AnnotationComment]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe AnnotationComment
Nothing -> [AnnotationComment] -> P [AnnotationComment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just AnnotationComment
c -> do
      [AnnotationComment]
rest <- Int -> P [AnnotationComment]
removeCommentTo' Int
line
      [AnnotationComment] -> P [AnnotationComment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotationComment
c AnnotationComment -> [AnnotationComment] -> [AnnotationComment]
forall a. a -> [a] -> [a]
: [AnnotationComment]
rest)

-- | Removes comments from the state while given predicate 'p' is true
removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment]
removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment]
removeComments RealLocated AnnotationComment -> Bool
p =
  (RealLocated AnnotationComment -> Bool)
-> P (Maybe AnnotationComment)
removeComment RealLocated AnnotationComment -> Bool
p P (Maybe AnnotationComment)
-> (Maybe AnnotationComment -> P [AnnotationComment])
-> P [AnnotationComment]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just AnnotationComment
c -> do
      [AnnotationComment]
rest <- (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment]
removeComments RealLocated AnnotationComment -> Bool
p
      [AnnotationComment] -> P [AnnotationComment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotationComment
c AnnotationComment -> [AnnotationComment] -> [AnnotationComment]
forall a. a -> [a] -> [a]
: [AnnotationComment]
rest)
    Maybe AnnotationComment
Nothing -> [AnnotationComment] -> P [AnnotationComment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Remove a comment from the state given predicate 'p'
removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment)
removeComment :: (RealLocated AnnotationComment -> Bool)
-> P (Maybe AnnotationComment)
removeComment RealLocated AnnotationComment -> Bool
p = do
  [RealLocated AnnotationComment]
comments <- (PrinterState -> [RealLocated AnnotationComment])
-> Printer [RealLocated AnnotationComment]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> [RealLocated AnnotationComment]
pendingComments

  let
    foundComment :: Maybe (RealLocated AnnotationComment)
foundComment =
      (RealLocated AnnotationComment -> Bool)
-> [RealLocated AnnotationComment]
-> Maybe (RealLocated AnnotationComment)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find RealLocated AnnotationComment -> Bool
p [RealLocated AnnotationComment]
comments

    newPendingComments :: [RealLocated AnnotationComment]
newPendingComments =
      [RealLocated AnnotationComment]
-> (RealLocated AnnotationComment
    -> [RealLocated AnnotationComment])
-> Maybe (RealLocated AnnotationComment)
-> [RealLocated AnnotationComment]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [RealLocated AnnotationComment]
comments (RealLocated AnnotationComment
-> [RealLocated AnnotationComment]
-> [RealLocated AnnotationComment]
forall a. Eq a => a -> [a] -> [a]
`delete` [RealLocated AnnotationComment]
comments) Maybe (RealLocated AnnotationComment)
foundComment

  (PrinterState -> PrinterState) -> Printer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \PrinterState
s -> PrinterState
s { pendingComments :: [RealLocated AnnotationComment]
pendingComments = [RealLocated AnnotationComment]
newPendingComments }
  Maybe AnnotationComment -> P (Maybe AnnotationComment)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AnnotationComment -> P (Maybe AnnotationComment))
-> Maybe AnnotationComment -> P (Maybe AnnotationComment)
forall a b. (a -> b) -> a -> b
$ (RealLocated AnnotationComment -> AnnotationComment)
-> Maybe (RealLocated AnnotationComment) -> Maybe AnnotationComment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(L RealSrcSpan
_ AnnotationComment
c) -> AnnotationComment
c) Maybe (RealLocated AnnotationComment)
foundComment

-- | Get all annotations for 'SrcSpan'
getAnnot :: SrcSpan -> P [AnnKeywordId]
getAnnot :: SrcSpan -> P [AnnKeywordId]
getAnnot SrcSpan
spn = (PrinterState -> [AnnKeywordId]) -> P [AnnKeywordId]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (SrcSpan -> Module -> [AnnKeywordId]
lookupAnnotation SrcSpan
spn (Module -> [AnnKeywordId])
-> (PrinterState -> Module) -> PrinterState -> [AnnKeywordId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrinterState -> Module
parsedModule)

-- | Get current line
getCurrentLine :: P String
getCurrentLine :: Printer String
getCurrentLine = (PrinterState -> String) -> Printer String
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 = (String -> Int) -> Printer String -> Printer Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Printer String
getCurrentLine

-- | Peek at the next comment in the state
peekNextCommentPos :: P (Maybe SrcSpan)
peekNextCommentPos :: P (Maybe SrcSpan)
peekNextCommentPos = do
  (PrinterState -> [RealLocated AnnotationComment])
-> Printer [RealLocated AnnotationComment]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrinterState -> [RealLocated AnnotationComment]
pendingComments Printer [RealLocated AnnotationComment]
-> ([RealLocated AnnotationComment] -> Maybe SrcSpan)
-> P (Maybe SrcSpan)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (L RealSrcSpan
next AnnotationComment
_ : [RealLocated AnnotationComment]
_) -> SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
next)
    [] -> Maybe SrcSpan
forall a. Maybe a
Nothing

-- | Get attached comments belonging to '[Located a]' given
groupAttachedComments :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
groupAttachedComments :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
groupAttachedComments = [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
forall a.
[Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
go
  where
    go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
    go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
go (L SrcSpan
rspan a
x : [Located a]
xs) = do
      [AnnotationComment]
comments <- SrcSpan -> P [AnnotationComment]
removeCommentTo SrcSpan
rspan
      Maybe SrcSpan
nextGroupStartM <- P (Maybe SrcSpan)
peekNextCommentPos

      let
        sameGroupOf :: Maybe SrcSpan -> [Located a]
sameGroupOf = [Located a]
-> (SrcSpan -> [Located a]) -> Maybe SrcSpan -> [Located a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Located a]
xs \SrcSpan
nextGroupStart ->
          (Located a -> Bool) -> [Located a] -> [Located a]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(L SrcSpan
p a
_)-> SrcSpan
p SrcSpan -> SrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
< SrcSpan
nextGroupStart) [Located a]
xs

        restOf :: Maybe SrcSpan -> [Located a]
restOf = [Located a]
-> (SrcSpan -> [Located a]) -> Maybe SrcSpan -> [Located a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] \SrcSpan
nextGroupStart ->
          (Located a -> Bool) -> [Located a] -> [Located a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(L SrcSpan
p a
_) -> SrcSpan
p SrcSpan -> SrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
<= SrcSpan
nextGroupStart) [Located a]
xs

      [([AnnotationComment], NonEmpty (Located a))]
restGroups <- [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
forall a.
[Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
go (Maybe SrcSpan -> [Located a]
restOf Maybe SrcSpan
nextGroupStartM)
      [([AnnotationComment], NonEmpty (Located a))]
-> P [([AnnotationComment], NonEmpty (Located a))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([([AnnotationComment], NonEmpty (Located a))]
 -> P [([AnnotationComment], NonEmpty (Located a))])
-> [([AnnotationComment], NonEmpty (Located a))]
-> P [([AnnotationComment], NonEmpty (Located a))]
forall a b. (a -> b) -> a -> b
$ ([AnnotationComment]
comments, SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L SrcSpan
rspan a
x Located a -> [Located a] -> NonEmpty (Located a)
forall a. a -> [a] -> NonEmpty a
:| Maybe SrcSpan -> [Located a]
sameGroupOf Maybe SrcSpan
nextGroupStartM) ([AnnotationComment], NonEmpty (Located a))
-> [([AnnotationComment], NonEmpty (Located a))]
-> [([AnnotationComment], NonEmpty (Located a))]
forall a. a -> [a] -> [a]
: [([AnnotationComment], NonEmpty (Located a))]
restGroups

    go [Located a]
_ = [([AnnotationComment], NonEmpty (Located a))]
-> P [([AnnotationComment], NonEmpty (Located a))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | A view on 'groupAttachedComments': return 'Just' when there is just a
--   one big group without any comments.
groupWithoutComments
    :: [([AnnotationComment], NonEmpty (Located a))]
    -> Maybe [Located a]
groupWithoutComments :: [([AnnotationComment], NonEmpty (Located a))] -> Maybe [Located a]
groupWithoutComments [([AnnotationComment], NonEmpty (Located a))]
grouped
    | (([AnnotationComment], NonEmpty (Located a)) -> Bool)
-> [([AnnotationComment], NonEmpty (Located a))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([AnnotationComment] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([AnnotationComment] -> Bool)
-> (([AnnotationComment], NonEmpty (Located a))
    -> [AnnotationComment])
-> ([AnnotationComment], NonEmpty (Located a))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([AnnotationComment], NonEmpty (Located a)) -> [AnnotationComment]
forall a b. (a, b) -> a
fst) [([AnnotationComment], NonEmpty (Located a))]
grouped
    = [Located a] -> Maybe [Located a]
forall a. a -> Maybe a
Just ([Located a] -> Maybe [Located a])
-> [Located a] -> Maybe [Located a]
forall a b. (a -> b) -> a -> b
$ (([AnnotationComment], NonEmpty (Located a)) -> [Located a])
-> [([AnnotationComment], NonEmpty (Located a))] -> [Located a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NonEmpty (Located a) -> [Located a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Located a) -> [Located a])
-> (([AnnotationComment], NonEmpty (Located a))
    -> NonEmpty (Located a))
-> ([AnnotationComment], NonEmpty (Located a))
-> [Located a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([AnnotationComment], NonEmpty (Located a)) -> NonEmpty (Located a)
forall a b. (a, b) -> b
snd) [([AnnotationComment], NonEmpty (Located a))]
grouped
    | Bool
otherwise
    = Maybe [Located a]
forall a. Maybe a
Nothing

modifyCurrentLine :: (String -> String) -> P ()
modifyCurrentLine :: (String -> String) -> Printer ()
modifyCurrentLine String -> String
f = do
    PrinterState
s0 <- Printer PrinterState
forall s (m :: * -> *). MonadState s m => m s
get
    PrinterState -> Printer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
s0 {currentLine :: String
currentLine = String -> String
f (String -> String) -> String -> String
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 :: P a -> P a -> P a
wrapping P a
p1 P a
p2 = do
    Maybe Int
maxCols <- (PrinterConfig -> Maybe Int) -> Printer (Maybe Int)
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 <- Printer PrinterState
forall s (m :: * -> *). MonadState s m => m s
get
            a
x <- P a
p1
            PrinterState
s1 <- Printer PrinterState
forall s (m :: * -> *). MonadState s m => m s
get
            if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrinterState -> String
currentLine PrinterState
s1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c
                -- No need to wrap
                then a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                else do
                    PrinterState -> Printer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
s0
                    a
y <- P a
p2
                    PrinterState
s2 <- Printer PrinterState
forall s (m :: * -> *). MonadState s m => m s
get
                    if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrinterState -> String
currentLine PrinterState
s1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrinterState -> String
currentLine PrinterState
s2)
                        -- Wrapping didn't help!
                        then PrinterState -> Printer ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PrinterState
s1 Printer () -> P a -> P a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                        -- Wrapped
                        else a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
y

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