{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Ormolu.Printer.Internal
(
R,
runR,
txt,
interferingTxt,
atom,
space,
newline,
useRecordDot,
inci,
sitcc,
Layout (..),
enterLayout,
vlayout,
getLayout,
useBraces,
dontUseBraces,
canUseBraces,
CommentPosition (..),
registerPendingCommentLine,
trimSpanStream,
nextEltSpan,
popComment,
getEnclosingSpan,
withEnclosingSpan,
thisLineSpans,
SpanMark (..),
spanMarkSpan,
HaddockStyle (..),
setSpanMark,
getSpanMark,
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,
scIndent :: !Int,
scBuilder :: Builder,
scSpanStream :: SpanStream,
scThisLineSpans :: [RealSrcSpan],
scCommentStream :: CommentStream,
scPendingComments :: ![(CommentPosition, Text)],
scRequestedDelimiter :: !RequestedDelimiter,
scSpanMark :: !(Maybe SpanMark)
}
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,
scIndent = 0,
scBuilder = mempty,
scSpanStream = sstream,
scThisLineSpans = [],
scCommentStream = cstream,
scPendingComments = [],
scRequestedDelimiter = VeryBeginning,
scSpanMark = Nothing
}
data SpitType
=
SimpleText
|
InterferingText
|
Atom
|
CommentPart
deriving (Show, Eq)
txt ::
Text ->
R ()
txt = spit SimpleText
interferingTxt ::
Text ->
R ()
interferingTxt = spit InterferingText
atom ::
Outputable a =>
a ->
R ()
atom = spit Atom . T.pack . showOutputable
spit ::
SpitType ->
Text ->
R ()
spit stype text = do
requestedDel <- R (gets scRequestedDelimiter)
pendingComments <- R (gets scPendingComments)
when (stype == InterferingText && not (null pendingComments)) newline
case requestedDel of
RequestedNewline -> do
R . modify $ \sc ->
sc
{ scRequestedDelimiter = RequestedNothing
}
case stype of
CommentPart -> newlineRaw
_ -> newline
_ -> return ()
R $ do
i <- asks rcIndent
c <- gets scColumn
closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans
let indentedTxt = spaces <> text
spaces = T.replicate spacesN " "
spacesN =
if c == 0
then i
else bool 0 1 (requestedDel == RequestedSpace)
modify $ \sc ->
sc
{ scBuilder = scBuilder sc <> fromText indentedTxt,
scColumn = scColumn sc + T.length indentedTxt,
scIndent =
if c == 0
then i
else scIndent sc,
scThisLineSpans =
let xs = scThisLineSpans sc
in case stype of
Atom -> case closestEnclosing of
Nothing -> xs
Just x -> x : xs
_ -> xs,
scRequestedDelimiter = RequestedNothing,
scSpanMark =
if (stype == CommentPart) || (not . null . scPendingComments) sc
then scSpanMark sc
else Nothing
}
space :: R ()
space = R . modify $ \sc ->
sc
{ scRequestedDelimiter = case scRequestedDelimiter sc of
RequestedNothing -> RequestedSpace
other -> other
}
newline :: R ()
newline = do
indent <- R (gets scIndent)
cs <- reverse <$> R (gets scPendingComments)
case cs of
[] -> newlineRaw
((position, _) : _) -> do
case position of
OnTheSameLine -> space
OnNextLine -> newlineRaw
R . forM_ cs $ \(_, text) ->
let modRC rc =
rc
{ rcIndent = indent
}
R m = do
unless (T.null text) $
spit CommentPart text
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,
scIndent = 0,
scThisLineSpans = [],
scRequestedDelimiter = case scRequestedDelimiter sc of
AfterNewline -> RequestedNewline
RequestedNewline -> RequestedNewline
VeryBeginning -> VeryBeginning
_ -> AfterNewline
}
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))
}
R (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 text = R $ do
modify $ \sc ->
sc
{ scPendingComments = (position, text) : 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
}
thisLineSpans :: R [RealSrcSpan]
thisLineSpans = R (gets scThisLineSpans)
data SpanMark
=
HaddockSpan HaddockStyle RealSrcSpan
|
CommentSpan RealSrcSpan
|
StatementSpan RealSrcSpan
spanMarkSpan :: SpanMark -> RealSrcSpan
spanMarkSpan = \case
HaddockSpan _ s -> s
CommentSpan s -> s
StatementSpan s -> s
data HaddockStyle
=
Pipe
|
Caret
|
Asterisk Int
|
Named String
setSpanMark ::
SpanMark ->
R ()
setSpanMark spnMark = R . modify $ \sc ->
sc
{ scSpanMark = Just spnMark
}
getSpanMark :: R (Maybe SpanMark)
getSpanMark = R (gets scSpanMark)
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