{-# 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
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
  }

-- | Run printer to get printed lines out of module as well as return value of monad
runPrinter :: PrinterConfig -> Printer a -> (a, Lines)
runPrinter :: 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 -> 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 -> 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_ :: 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 :: 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 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.EpaLineComment String
s     -> String -> Printer ()
putText String
s
  GHC.EpaDocCommentNext String
s  -> String -> Printer ()
putText String
s
  GHC.EpaDocCommentPrev String
s  -> String -> Printer ()
putText String
s
  GHC.EpaDocCommentNamed String
s -> String -> Printer ()
putText String
s
  GHC.EpaDocSection Int
_ 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

putMaybeLineComment :: Maybe GHC.EpaComment -> P ()
putMaybeLineComment :: Maybe EpaComment -> Printer ()
putMaybeLineComment = \case
    Maybe EpaComment
Nothing  -> () -> Printer ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just EpaComment
cmt -> Printer ()
space Printer () -> Printer () -> Printer ()
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 (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)

nameAnnAdornments :: [GHC.NameAnn] -> (String, String)
nameAnnAdornments :: [NameAnn] -> (String, String)
nameAnnAdornments = ((String, String) -> NameAnn -> (String, String))
-> (String, String) -> [NameAnn] -> (String, String)
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]
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.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 {}   -> (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 (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
>> 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [Printer ()]
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
space)
      ((GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [Printer ()]
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
_ 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
    GenLocated SrcSpanAnnN RdrName -> Printer ()
putRdrName LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
rdrName
  GHC.HsTyLit XTyLit GhcPs
_ HsTyLit
tp ->
    HsTyLit -> Printer ()
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
"("
    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)
      ((GenLocated SrcSpanAnnA (HsType GhcPs) -> Printer ())
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [Printer ()]
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
_ 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
_ HsSplice 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
_ LHsDocString
_ ->
    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 :: 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

-- | 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

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}