{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
module Language.Haskell.Stylish.Printer
( Printer(..)
, PrinterConfig(..)
, PrinterState(..)
, P
, runPrinter
, runPrinter_
, 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
, 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)
type P = Printer
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)
data PrinterConfig = PrinterConfig
{ PrinterConfig -> Maybe Int
columns :: !(Maybe Int)
}
data PrinterState = PrinterState
{ PrinterState -> Lines
lines :: !Lines
, PrinterState -> Int
linePos :: !Int
, PrinterState -> String
currentLine :: !String
, :: ![RealLocated AnnotationComment]
, PrinterState -> Module
parsedModule :: !Module
}
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])
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)
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 }
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
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
putAllSpanComments :: P () -> SrcSpan -> P ()
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)
putComment :: AnnotationComment -> P ()
= \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
putEolComment :: SrcSpan -> P ()
= \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 ()
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)
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
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
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
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] }
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 :: 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
")"
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 :: 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 :: 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
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
removeLineComment :: Int -> P (Maybe AnnotationComment)
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)
removeCommentTo :: SrcSpan -> P [AnnotationComment]
= \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)
removeCommentToEnd :: SrcSpan -> P [AnnotationComment]
= \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)
removeCommentTo' :: Int -> P [AnnotationComment]
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)
removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment]
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 []
removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment)
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
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)
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 (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
peekNextCommentPos :: P (Maybe SrcSpan)
= 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
groupAttachedComments :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))]
= [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 []
groupWithoutComments
:: [([AnnotationComment], NonEmpty (Located a))]
-> Maybe [Located a]
[([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
-> P a
-> P a
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
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
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)
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
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}