{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Ormolu.Printer.Internal
(
R,
runR,
txt,
atom,
space,
newline,
isLineDirty,
useRecordDot,
inci,
sitcc,
Layout (..),
enterLayout,
vlayout,
getLayout,
useBraces,
dontUseBraces,
canUseBraces,
CommentPosition (..),
registerPendingCommentLine,
trimSpanStream,
nextEltSpan,
popComment,
getEnclosingSpan,
withEnclosingSpan,
HaddockStyle (..),
setLastCommentSpan,
getLastCommentSpan,
getAnns,
)
where
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bool (bool)
import Data.Coerce
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder
import GHC
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Printer.SpanStream
import Ormolu.Utils (showOutputable)
import Outputable (Outputable)
newtype R a = R (ReaderT RC (State SC) a)
deriving (Functor, Applicative, Monad)
data RC
= RC
{
rcIndent :: !Int,
rcLayout :: Layout,
rcEnclosingSpans :: [RealSrcSpan],
rcAnns :: Anns,
rcCanUseBraces :: Bool,
rcUseRecDot :: Bool
}
data SC
= SC
{
scColumn :: !Int,
scBuilder :: Builder,
scSpanStream :: SpanStream,
scCommentStream :: CommentStream,
scPendingComments :: ![(CommentPosition, Int, Text)],
scDirtyLine :: !Bool,
scRequestedDelimiter :: !RequestedDelimiter,
scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
}
data RequestedDelimiter
=
RequestedSpace
|
RequestedNewline
|
RequestedNothing
|
AfterNewline
|
VeryBeginning
deriving (Eq, Show)
data Layout
=
SingleLine
|
MultiLine
deriving (Eq, Show)
data CommentPosition
=
OnTheSameLine
|
OnNextLine
deriving (Eq, Show)
runR ::
R () ->
SpanStream ->
CommentStream ->
Anns ->
Bool ->
Text
runR (R m) sstream cstream anns recDot =
TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
where
rc =
RC
{ rcIndent = 0,
rcLayout = MultiLine,
rcEnclosingSpans = [],
rcAnns = anns,
rcCanUseBraces = False,
rcUseRecDot = recDot
}
sc =
SC
{ scColumn = 0,
scBuilder = mempty,
scSpanStream = sstream,
scCommentStream = cstream,
scPendingComments = [],
scDirtyLine = False,
scRequestedDelimiter = VeryBeginning,
scLastCommentSpan = Nothing
}
txt ::
Text ->
R ()
txt = spit False False
atom ::
Outputable a =>
a ->
R ()
atom = spit True False . T.pack . showOutputable
spit ::
Bool ->
Bool ->
Text ->
R ()
spit dirty printingComments txt' = do
requestedDel <- R (gets scRequestedDelimiter)
case requestedDel of
RequestedNewline -> do
R . modify $ \sc ->
sc
{ scRequestedDelimiter = RequestedNothing
}
if printingComments
then newlineRaw
else newline
_ -> return ()
R $ do
i <- asks rcIndent
c <- gets scColumn
let spaces =
if c < i
then T.replicate (i - c) " "
else bool mempty " " (requestedDel == RequestedSpace)
indentedTxt = spaces <> txt'
modify $ \sc ->
sc
{ scBuilder = scBuilder sc <> fromText indentedTxt,
scColumn = scColumn sc + T.length indentedTxt,
scDirtyLine = scDirtyLine sc || dirty,
scRequestedDelimiter = RequestedNothing,
scLastCommentSpan =
if printingComments || (not . null . scPendingComments) sc
then scLastCommentSpan sc
else Nothing
}
space :: R ()
space = R . modify $ \sc ->
sc
{ scRequestedDelimiter = case scRequestedDelimiter sc of
RequestedNothing -> RequestedSpace
other -> other
}
newline :: R ()
newline = do
cs <- reverse <$> R (gets scPendingComments)
case cs of
[] -> newlineRaw
((position, _, _) : _) -> do
case position of
OnTheSameLine -> space
OnNextLine -> newlineRaw
R . forM_ cs $ \(_, indent, txt') ->
let modRC rc =
rc
{ rcIndent = indent
}
R m = do
unless (T.null txt') $
spit False True txt'
newlineRaw
in local modRC m
R . modify $ \sc ->
sc
{ scPendingComments = []
}
newlineRaw :: R ()
newlineRaw = R . modify $ \sc ->
let requestedDel = scRequestedDelimiter sc
builderSoFar = scBuilder sc
in sc
{ scBuilder = case requestedDel of
AfterNewline -> builderSoFar
RequestedNewline -> builderSoFar
VeryBeginning -> builderSoFar
_ -> builderSoFar <> "\n",
scColumn = 0,
scDirtyLine = False,
scRequestedDelimiter = case scRequestedDelimiter sc of
AfterNewline -> RequestedNewline
RequestedNewline -> RequestedNewline
VeryBeginning -> VeryBeginning
_ -> AfterNewline
}
isLineDirty :: R Bool
isLineDirty = R (gets scDirtyLine)
useRecordDot :: R Bool
useRecordDot = R $ asks rcUseRecDot
inci :: R () -> R ()
inci (R m) = R (local modRC m)
where
modRC rc =
rc
{ rcIndent = rcIndent rc + indentStep
}
sitcc :: R () -> R ()
sitcc (R m) = do
requestedDel <- R (gets scRequestedDelimiter)
i <- R (asks rcIndent)
c <- R (gets scColumn)
let modRC rc =
rc
{ rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
}
vlayout (R m) . R $ do
modify $ \sc ->
sc
{ scRequestedDelimiter = case requestedDel of
RequestedSpace -> RequestedNothing
other -> other
}
local modRC m
enterLayout :: Layout -> R () -> R ()
enterLayout l (R m) = R (local modRC m)
where
modRC rc =
rc
{ rcLayout = l
}
vlayout ::
R a ->
R a ->
R a
vlayout sline mline = do
l <- getLayout
case l of
SingleLine -> sline
MultiLine -> mline
getLayout :: R Layout
getLayout = R (asks rcLayout)
registerPendingCommentLine ::
CommentPosition ->
Text ->
R ()
registerPendingCommentLine position txt' = R $ do
i <- asks rcIndent
modify $ \sc ->
sc
{ scPendingComments = (position, i, txt') : scPendingComments sc
}
trimSpanStream ::
RealSrcSpan ->
R ()
trimSpanStream ref = do
let leRef :: RealSrcSpan -> Bool
leRef x = realSrcSpanStart x <= realSrcSpanStart ref
R . modify $ \sc ->
sc
{ scSpanStream = coerce (dropWhile leRef) (scSpanStream sc)
}
nextEltSpan :: R (Maybe RealSrcSpan)
nextEltSpan = listToMaybe . coerce <$> R (gets scSpanStream)
popComment ::
(RealLocated Comment -> Bool) ->
R (Maybe (RealLocated Comment))
popComment f = R $ do
CommentStream cstream <- gets scCommentStream
case cstream of
[] -> return Nothing
(x : xs) ->
if f x
then
Just x
<$ modify
( \sc ->
sc
{ scCommentStream = CommentStream xs
}
)
else return Nothing
getEnclosingSpan ::
(RealSrcSpan -> Bool) ->
R (Maybe RealSrcSpan)
getEnclosingSpan f =
listToMaybe . filter f <$> R (asks rcEnclosingSpans)
withEnclosingSpan :: RealSrcSpan -> R () -> R ()
withEnclosingSpan spn (R m) = R (local modRC m)
where
modRC rc =
rc
{ rcEnclosingSpans = spn : rcEnclosingSpans rc
}
data HaddockStyle
=
Pipe
|
Caret
|
Asterisk Int
|
Named String
setLastCommentSpan ::
Maybe HaddockStyle ->
RealSrcSpan ->
R ()
setLastCommentSpan mhStyle spn = R . modify $ \sc ->
sc
{ scLastCommentSpan = Just (mhStyle, spn)
}
getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
getLastCommentSpan = R (gets scLastCommentSpan)
getAnns ::
SrcSpan ->
R [AnnKeywordId]
getAnns spn = lookupAnns spn <$> R (asks rcAnns)
useBraces :: R () -> R ()
useBraces (R r) = R (local (\i -> i {rcCanUseBraces = True}) r)
dontUseBraces :: R () -> R ()
dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
canUseBraces :: R Bool
canUseBraces = R $ asks rcCanUseBraces
indentStep :: Int
indentStep = 2