{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Language.Haskell.Stylish.Printer
( Printer(..)
, PrinterConfig(..)
, PrinterState(..)
, P
, runPrinter
, runPrinter_
, comma
, dot
, getCurrentLine
, getCurrentLineLength
, newline
, parenthesize
, prefix
, putComment
, putMaybeLineComment
, putOutputable
, putCond
, putType
, putRdrName
, putText
, sep
, space
, spaces
, suffix
, pad
, 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)
type P = Printer
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)
data PrinterConfig = PrinterConfig
{ PrinterConfig -> Maybe Int
columns :: !(Maybe Int)
}
data PrinterState = PrinterState
{ PrinterState -> Lines
lines :: !Lines
, PrinterState -> Int
linePos :: !Int
, PrinterState -> String
currentLine :: !String
}
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])
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)
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 }
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
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
putComment :: GHC.EpaComment -> P ()
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 ()
= \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
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
"]")
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
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
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] }
space :: P ()
space :: Printer ()
space = String -> Printer ()
putText String
" "
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
dot :: P ()
dot :: Printer ()
dot = String -> Printer ()
putText String
"."
comma :: P ()
comma :: Printer ()
comma = String -> Printer ()
putText String
","
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
")"
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 :: 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 :: 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
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
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
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
-> P a
-> P a
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
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
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)
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
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}