{-# 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
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
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
$cpure :: forall a. a -> Printer a
pure :: forall a. a -> Printer a
$c<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
<*> :: forall a b. Printer (a -> b) -> Printer a -> Printer b
$cliftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
liftA2 :: forall a b c. (a -> b -> c) -> Printer a -> Printer b -> Printer c
$c*> :: forall a b. Printer a -> Printer b -> Printer b
*> :: forall a b. Printer a -> Printer b -> Printer b
$c<* :: forall a b. Printer a -> Printer b -> Printer a
<* :: forall a b. Printer a -> Printer b -> Printer a
Applicative, (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
$cfmap :: forall a b. (a -> b) -> Printer a -> Printer b
fmap :: forall a b. (a -> b) -> Printer a -> Printer b
$c<$ :: forall a b. a -> Printer b -> Printer a
<$ :: forall a b. a -> Printer b -> Printer a
Functor, Applicative Printer
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
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
$c>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
>>= :: forall a b. Printer a -> (a -> Printer b) -> Printer b
$c>> :: forall a b. Printer a -> Printer b -> Printer b
>> :: forall a b. Printer a -> Printer b -> Printer b
$creturn :: forall a. a -> Printer a
return :: forall a. a -> Printer a
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) = ReaderT PrinterConfig (State PrinterState) a
-> PrinterConfig -> StateT PrinterState Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PrinterConfig (State PrinterState) a
printer PrinterConfig
cfg StateT PrinterState Identity a -> PrinterState -> (a, PrinterState)
forall s a. State s a -> s -> (a, s)
`runState` Lines -> Int -> String -> PrinterState
PrinterState [] Int
0 String
""
  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 -> Printer a -> Lines
runPrinter_ :: forall a. PrinterConfig -> Printer a -> Lines
runPrinter_ PrinterConfig
cfg Printer a
printer = (a, Lines) -> Lines
forall a b. (a, b) -> b
snd (PrinterConfig -> Printer a -> (a, Lines)
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 <- (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 = l <> 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 <- 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 a. a -> Printer a
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 a b. Printer a -> Printer b -> Printer 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 :: forall a. Outputable a => 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 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 (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ HsDocString -> String
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     -> () -> Printer ()
forall a. a -> Printer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

putMaybeLineComment :: Maybe GHC.EpaComment -> P ()
putMaybeLineComment :: Maybe EpaComment -> Printer ()
putMaybeLineComment = \case
    Maybe EpaComment
Nothing  -> () -> Printer ()
forall a. a -> Printer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just EpaComment
cmt -> Printer ()
space Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
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 GenLocated SrcSpanAnnN RdrName -> RdrName
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 ([NameAnn] -> (String, String)) -> [NameAnn] -> (String, String)
forall a b. (a -> b) -> a -> b
$
            EpAnn NameAnn -> [NameAnn]
forall a. EpAnn a -> [a]
GHC.epAnnAnnsL (EpAnn NameAnn -> [NameAnn]) -> EpAnn NameAnn -> [NameAnn]
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnN -> EpAnn NameAnn
forall a. SrcSpanAnn' a -> a
GHC.ann (SrcSpanAnnN -> EpAnn NameAnn) -> SrcSpanAnnN -> EpAnn NameAnn
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> SrcSpanAnnN
forall l e. GenLocated l e -> l
GHC.getLoc GenLocated SrcSpanAnnN RdrName
rdrName
      String -> Printer ()
putText String
pre
      String -> Printer ()
putText (OccName -> String
forall a. Outputable a => a -> String
showOutputable OccName
name)
      String -> Printer ()
putText String
post
    Qual ModuleName
modulePrefix OccName
name ->
      ModuleName -> Printer ()
putModuleName ModuleName
modulePrefix Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
dot Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
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)

nameAnnAdornments :: [GHC.NameAnn] -> (String, String)
nameAnnAdornments :: [NameAnn] -> (String, String)
nameAnnAdornments = ((String, String) -> NameAnn -> (String, String))
-> (String, String) -> [NameAnn] -> (String, String)
forall b a. (b -> a -> b) -> b -> [a] -> b
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l, String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
accr))
    (String
forall a. Monoid a => a
mempty, String
forall a. Monoid a => a
mempty)

nameAnnAdornment :: GHC.NameAnn -> (String, String)
nameAnnAdornment :: NameAnn -> (String, String)
nameAnnAdornment = \case
    GHC.NameAnn {[TrailingAnn]
NameAdornment
EpaLocation
nann_adornment :: NameAdornment
nann_open :: EpaLocation
nann_name :: EpaLocation
nann_close :: EpaLocation
nann_trailing :: [TrailingAnn]
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_name :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
..}       -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnCommas {[TrailingAnn]
[EpaLocation]
NameAdornment
EpaLocation
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
nann_adornment :: NameAdornment
nann_open :: EpaLocation
nann_commas :: [EpaLocation]
nann_close :: EpaLocation
nann_trailing :: [TrailingAnn]
nann_commas :: NameAnn -> [EpaLocation]
..} -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnBars {[TrailingAnn]
[EpaLocation]
NameAdornment
EpaLocation
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
nann_adornment :: NameAdornment
nann_open :: EpaLocation
nann_bars :: [EpaLocation]
nann_close :: EpaLocation
nann_trailing :: [TrailingAnn]
nann_bars :: NameAnn -> [EpaLocation]
..}   -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnOnly {[TrailingAnn]
NameAdornment
EpaLocation
nann_adornment :: NameAnn -> NameAdornment
nann_open :: NameAnn -> EpaLocation
nann_close :: NameAnn -> EpaLocation
nann_trailing :: NameAnn -> [TrailingAnn]
nann_adornment :: NameAdornment
nann_open :: EpaLocation
nann_close :: EpaLocation
nann_trailing :: [TrailingAnn]
..}   -> NameAdornment -> (String, String)
fromAdornment NameAdornment
nann_adornment
    GHC.NameAnnRArrow {}   -> (String
forall a. Monoid a => a
mempty, String
forall a. Monoid a => a
mempty)
    GHC.NameAnnQuote {}    -> (String
"'", String
forall a. Monoid a => a
mempty)
    GHC.NameAnnTrailing {} -> (String
forall a. Monoid a => a
mempty, String
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 (String -> Printer ())
-> (ModuleName -> String) -> ModuleName -> Printer ()
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 GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp of
  GHC.HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
arrowTp LHsType GhcPs
argTp LHsType GhcPs
funTp -> do
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
argTp
    Printer ()
space
    case HsArrow GhcPs
arrowTp of
        GHC.HsUnrestrictedArrow {} -> String -> Printer ()
putText String
"->"
        GHC.HsLinearArrow {}       -> String -> Printer ()
putText String
"%1 ->"
        GHC.HsExplicitMult {}      -> HsArrow GhcPs -> Printer ()
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 Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
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
"'["
    Printer () -> [Printer ()] -> Printer ()
forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Printer ()
GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
putType [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
xs)
    String -> Printer ()
putText String
"]"
  GHC.HsExplicitTupleTy XExplicitTupleTy GhcPs
_ [LHsType GhcPs]
xs -> do
    String -> Printer ()
putText String
"'("
    Printer () -> [Printer ()] -> Printer ()
forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Printer ()
GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
putType [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType 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
GenLocated SrcSpanAnnN RdrName
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 -> () -> Printer ()
forall a. a -> Printer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    GenLocated SrcSpanAnnN RdrName -> Printer ()
putRdrName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
rdrName
  GHC.HsTyLit XTyLit GhcPs
_ HsTyLit GhcPs
tp ->
    HsTyLit GhcPs -> Printer ()
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
"("
    Printer () -> [Printer ()] -> Printer ()
forall a. P a -> [P a] -> Printer ()
sep
      (Printer ()
comma Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> Printer ()
GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
putType [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
xs)
    String -> Printer ()
putText String
")"
  GHC.HsForAllTy {} ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsQualTy {} ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsAppKindTy XAppKindTy GhcPs
_ LHsType GhcPs
_ LHsToken "@" GhcPs
_ LHsType GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsListTy XListTy GhcPs
_ LHsType GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsSumTy XSumTy GhcPs
_ [LHsType GhcPs]
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsIParamTy XIParamTy GhcPs
_ XRec GhcPs HsIPName
_ LHsType GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsKindSig XKindSig GhcPs
_ LHsType GhcPs
_ LHsType GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsStarTy XStarTy GhcPs
_ Bool
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsSpliceTy XSpliceTy GhcPs
_ HsUntypedSplice GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsDocTy XDocTy GhcPs
_ LHsType GhcPs
_ LHsDoc GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsBangTy XBangTy GhcPs
_ HsSrcBang
_ LHsType GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.HsWildCardTy XWildCardTy GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp
  GHC.XHsType XXType GhcPs
_ ->
    GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ()
forall a. Outputable a => a -> Printer ()
putOutputable LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ltp

-- | 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 = "", linePos = 0, lines = lines s <> [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 :: forall a. P a -> P a
parenthesize P a
action = String -> Printer ()
putText String
"(" Printer () -> P a -> P a
forall a b. Printer a -> Printer b -> Printer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
action P a -> Printer () -> P a
forall a b. Printer a -> Printer b -> Printer 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 :: forall a. P a -> [P a] -> Printer ()
sep P a
_ []             = () -> Printer ()
forall a. a -> Printer a
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 a b. Printer a -> Printer b -> Printer b
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 a b. Printer a -> Printer b -> Printer b
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 P a -> P b -> P b
forall a b. Printer a -> Printer b -> Printer 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 :: forall a b. Printer a -> Printer b -> Printer a
suffix P a
pa P b
pb = P b
pb P b -> P a -> P a
forall a b. Printer a -> Printer b -> Printer b
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 a. [a] -> 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

-- | 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 a b. (a -> b) -> Printer a -> Printer b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Printer String
getCurrentLine

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 = f $ currentLine 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 <- (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 a. [a] -> 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 a. a -> Printer 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 a. [a] -> 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 a. [a] -> 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 a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> P a
forall a. a -> Printer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                        -- Wrapped
                        else a -> P a
forall a. a -> Printer a
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 = (PrinterConfig -> PrinterConfig) -> Printer a -> Printer a
forall a.
(PrinterConfig -> PrinterConfig) -> Printer a -> Printer a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((PrinterConfig -> PrinterConfig) -> Printer a -> Printer a)
-> (PrinterConfig -> PrinterConfig) -> Printer a -> Printer a
forall a b. (a -> b) -> a -> b
$ \PrinterConfig
pc -> PrinterConfig
pc {columns = c}