{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf            #-}

module Development.IDE.Spans.Pragmas
  ( NextPragmaInfo(..)
  , LineSplitTextEdits(..)
  , getNextPragmaInfo
  , insertNewPragma
  , getFirstPragma ) where

import           Control.Lens                    ((&), (.~))
import           Data.Bits                       (Bits (setBit))
import qualified Data.List                       as List
import qualified Data.Maybe                      as Maybe
import           Data.Text                       (Text, pack)
import qualified Data.Text                       as Text
import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction)
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util
import qualified Language.LSP.Protocol.Types    as LSP
import           Control.Monad.IO.Class         (MonadIO (..))
import           Control.Monad.Trans.Except     (ExceptT)
import           Ide.Plugin.Error               (PluginError)
import           Ide.Types                      (PluginId(..))
import qualified Data.Text                      as T
import           Development.IDE.Core.PluginUtils
import qualified Language.LSP.Protocol.Lens     as L

getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo
getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo
getNextPragmaInfo DynFlags
dynFlags Maybe Text
mbSourceText =
  if | Just Text
sourceText <- Maybe Text
mbSourceText
     , let sourceStringBuffer :: StringBuffer
sourceStringBuffer = [Char] -> StringBuffer
stringToStringBuffer (Text -> [Char]
Text.unpack Text
sourceText)
     , POk PState
_ ParserState
parserState <- DynFlags -> StringBuffer -> ParseResult ParserState
parsePreDecl DynFlags
dynFlags StringBuffer
sourceStringBuffer
     -> case ParserState
parserState of
         ParserStateNotDone{ NextPragmaInfo
nextPragma :: NextPragmaInfo
$sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
nextPragma } -> NextPragmaInfo
nextPragma
         ParserStateDone{ NextPragmaInfo
$sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
nextPragma :: NextPragmaInfo
nextPragma }    -> NextPragmaInfo
nextPragma
     | Bool
otherwise
     -> Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo Int
0 Maybe LineSplitTextEdits
forall a. Maybe a
Nothing

-- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`
-- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4
-- GHC as well, hence the replacement.
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156
showExtension :: Extension -> Text
showExtension :: Extension -> Text
showExtension Extension
NamedFieldPuns = Text
"NamedFieldPuns"
showExtension Extension
ext = [Char] -> Text
pack (Extension -> [Char]
forall a. Show a => a -> [Char]
show Extension
ext)

insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit
insertNewPragma :: NextPragmaInfo -> Extension -> TextEdit
insertNewPragma (NextPragmaInfo Int
_ (Just (LineSplitTextEdits TextEdit
ins TextEdit
_))) Extension
newPragma = TextEdit
ins TextEdit -> (TextEdit -> TextEdit) -> TextEdit
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> TextEdit -> Identity TextEdit
forall s a. HasNewText s a => Lens' s a
Lens' TextEdit Text
L.newText ((Text -> Identity Text) -> TextEdit -> Identity TextEdit)
-> Text -> TextEdit -> TextEdit
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"{-# LANGUAGE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Extension -> Text
showExtension Extension
newPragma Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n" :: LSP.TextEdit
insertNewPragma (NextPragmaInfo Int
nextPragmaLine Maybe LineSplitTextEdits
_) Extension
newPragma =  Range -> Text -> TextEdit
LSP.TextEdit Range
pragmaInsertRange (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ Text
"{-# LANGUAGE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Extension -> Text
showExtension Extension
newPragma Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"
    where
        pragmaInsertPosition :: Position
pragmaInsertPosition = UInt -> UInt -> Position
LSP.Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nextPragmaLine) UInt
0
        pragmaInsertRange :: Range
pragmaInsertRange = Position -> Position -> Range
LSP.Range Position
pragmaInsertPosition Position
pragmaInsertPosition

getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo
getFirstPragma :: forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m NextPragmaInfo
getFirstPragma (PluginId Text
pId) IdeState
state NormalizedFilePath
nfp = do
  (HscEnvEq -> HscEnv
hscEnv -> HscEnv -> DynFlags
hsc_dflags -> DynFlags
sessionDynFlags, PositionMapping
_) <- [Char]
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError m (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
[Char] -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (Text -> [Char]
T.unpack Text
pId [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".GhcSession") IdeState
state (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT PluginError m (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError m (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
nfp
  (UTCTime
_, Maybe Text
fileContents) <- IO (UTCTime, Maybe Text)
-> ExceptT PluginError m (UTCTime, Maybe Text)
forall a. IO a -> ExceptT PluginError m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text)
 -> ExceptT PluginError m (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text)
-> ExceptT PluginError m (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ [Char]
-> IdeState
-> Action (UTCTime, Maybe Text)
-> IO (UTCTime, Maybe Text)
forall a. [Char] -> IdeState -> Action a -> IO a
runAction (Text -> [Char]
T.unpack Text
pId [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".GetFileContents") IdeState
state (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
  NextPragmaInfo -> ExceptT PluginError m NextPragmaInfo
forall a. a -> ExceptT PluginError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NextPragmaInfo -> ExceptT PluginError m NextPragmaInfo)
-> NextPragmaInfo -> ExceptT PluginError m NextPragmaInfo
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe Text -> NextPragmaInfo
getNextPragmaInfo DynFlags
sessionDynFlags Maybe Text
fileContents

-- Pre-declaration comments parser -----------------------------------------------------

-- | Each mode represents the "strongest" thing we've seen so far.
-- From strongest to weakest:
-- ModePragma, ModeHaddock, ModeComment, ModeInitial
data Mode = ModePragma | ModeHaddock | ModeComment | ModeInitial deriving Int -> Mode -> [Char] -> [Char]
[Mode] -> [Char] -> [Char]
Mode -> [Char]
(Int -> Mode -> [Char] -> [Char])
-> (Mode -> [Char]) -> ([Mode] -> [Char] -> [Char]) -> Show Mode
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Mode -> [Char] -> [Char]
showsPrec :: Int -> Mode -> [Char] -> [Char]
$cshow :: Mode -> [Char]
show :: Mode -> [Char]
$cshowList :: [Mode] -> [Char] -> [Char]
showList :: [Mode] -> [Char] -> [Char]
Show

data LineSplitTextEdits = LineSplitTextEdits {
  LineSplitTextEdits -> TextEdit
lineSplitInsertTextEdit :: !LSP.TextEdit,
  LineSplitTextEdits -> TextEdit
lineSplitDeleteTextEdit :: !LSP.TextEdit
} deriving Int -> LineSplitTextEdits -> [Char] -> [Char]
[LineSplitTextEdits] -> [Char] -> [Char]
LineSplitTextEdits -> [Char]
(Int -> LineSplitTextEdits -> [Char] -> [Char])
-> (LineSplitTextEdits -> [Char])
-> ([LineSplitTextEdits] -> [Char] -> [Char])
-> Show LineSplitTextEdits
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> LineSplitTextEdits -> [Char] -> [Char]
showsPrec :: Int -> LineSplitTextEdits -> [Char] -> [Char]
$cshow :: LineSplitTextEdits -> [Char]
show :: LineSplitTextEdits -> [Char]
$cshowList :: [LineSplitTextEdits] -> [Char] -> [Char]
showList :: [LineSplitTextEdits] -> [Char] -> [Char]
Show

data NextPragmaInfo = NextPragmaInfo {
  NextPragmaInfo -> Int
nextPragmaLine     :: !Int,
  NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits :: !(Maybe LineSplitTextEdits)
} deriving Int -> NextPragmaInfo -> [Char] -> [Char]
[NextPragmaInfo] -> [Char] -> [Char]
NextPragmaInfo -> [Char]
(Int -> NextPragmaInfo -> [Char] -> [Char])
-> (NextPragmaInfo -> [Char])
-> ([NextPragmaInfo] -> [Char] -> [Char])
-> Show NextPragmaInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> NextPragmaInfo -> [Char] -> [Char]
showsPrec :: Int -> NextPragmaInfo -> [Char] -> [Char]
$cshow :: NextPragmaInfo -> [Char]
show :: NextPragmaInfo -> [Char]
$cshowList :: [NextPragmaInfo] -> [Char] -> [Char]
showList :: [NextPragmaInfo] -> [Char] -> [Char]
Show

data ParserState
  = ParserStateNotDone
    { ParserState -> NextPragmaInfo
nextPragma           :: !NextPragmaInfo
    , ParserState -> Mode
mode                 :: !Mode
    , ParserState -> Int
lastBlockCommentLine :: !Int
    , ParserState -> Int
lastPragmaLine       :: !Int
    , ParserState -> Bool
isLastTokenHash      :: !Bool
    }
  | ParserStateDone { nextPragma :: NextPragmaInfo }
  deriving Int -> ParserState -> [Char] -> [Char]
[ParserState] -> [Char] -> [Char]
ParserState -> [Char]
(Int -> ParserState -> [Char] -> [Char])
-> (ParserState -> [Char])
-> ([ParserState] -> [Char] -> [Char])
-> Show ParserState
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ParserState -> [Char] -> [Char]
showsPrec :: Int -> ParserState -> [Char] -> [Char]
$cshow :: ParserState -> [Char]
show :: ParserState -> [Char]
$cshowList :: [ParserState] -> [Char] -> [Char]
showList :: [ParserState] -> [Char] -> [Char]
Show

isPragma :: String -> Bool
isPragma :: [Char] -> Bool
isPragma = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
"{-#"

isDownwardBlockHaddock :: String -> Bool
isDownwardBlockHaddock :: [Char] -> Bool
isDownwardBlockHaddock = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
"{-|"

isDownwardLineHaddock :: String -> Bool
isDownwardLineHaddock :: [Char] -> Bool
isDownwardLineHaddock = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
"-- |"

-- need to merge tokens that are deleted/inserted into one TextEdit each
-- to work around some weird TextEdits applied in reversed order issue
updateLineSplitTextEdits :: LSP.Range -> String -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits :: Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
tokenRange [Char]
tokenString Maybe LineSplitTextEdits
mbPrevLineSplitTextEdits
  | Just LineSplitTextEdits
prevLineSplitTextEdits <- Maybe LineSplitTextEdits
mbPrevLineSplitTextEdits
  , let LineSplitTextEdits
          { $sel:lineSplitInsertTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
lineSplitInsertTextEdit = TextEdit
prevInsertTextEdit
          , $sel:lineSplitDeleteTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
lineSplitDeleteTextEdit = TextEdit
prevDeleteTextEdit } = LineSplitTextEdits
prevLineSplitTextEdits
  , let LSP.TextEdit Range
prevInsertRange Text
prevInsertText = TextEdit
prevInsertTextEdit
  , let LSP.TextEdit Range
prevDeleteRange Text
_prevDeleteText = TextEdit
prevDeleteTextEdit
  , let LSP.Range Position
prevInsertStartPos  Position
prevInsertEndPos = Range
prevInsertRange
  , let LSP.Position UInt
_prevInsertStartLine UInt
_prevInsertStartCol = Position
prevInsertStartPos
  , let LSP.Position UInt
_prevInsertEndLine UInt
_prevInsertEndCol = Position
prevInsertEndPos
  , let LSP.Range Position
prevDeleteStartPos Position
prevDeleteEndPos = Range
prevDeleteRange
  , let LSP.Position UInt
_prevDeleteStartLine UInt
_prevDeleteStartCol = Position
prevDeleteStartPos
  , let LSP.Position UInt
_prevDeleteEndLine UInt
prevDeleteEndCol = Position
prevDeleteEndPos
  , let currInsertRange :: Range
currInsertRange = Range
prevInsertRange
  , let currInsertText :: Text
currInsertText =
          HasCallStack => Text -> Text
Text -> Text
Text.init Text
prevInsertText
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
startCol UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
- UInt
prevDeleteEndCol) Text
" "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
List.take Int
newLineCol [Char]
tokenString)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  , let currInsertTextEdit :: TextEdit
currInsertTextEdit = Range -> Text -> TextEdit
LSP.TextEdit Range
currInsertRange Text
currInsertText
  , let currDeleteStartPos :: Position
currDeleteStartPos = Position
prevDeleteStartPos
  , let currDeleteEndPos :: Position
currDeleteEndPos = UInt -> UInt -> Position
LSP.Position UInt
endLine UInt
endCol
  , let currDeleteRange :: Range
currDeleteRange = Position -> Position -> Range
LSP.Range Position
currDeleteStartPos Position
currDeleteEndPos
  , let currDeleteTextEdit :: TextEdit
currDeleteTextEdit = Range -> Text -> TextEdit
LSP.TextEdit Range
currDeleteRange Text
""
  = TextEdit -> TextEdit -> LineSplitTextEdits
LineSplitTextEdits TextEdit
currInsertTextEdit TextEdit
currDeleteTextEdit
  | Bool
otherwise
  , let LSP.Range Position
startPos Position
_ = Range
tokenRange
  , let deleteTextEdit :: TextEdit
deleteTextEdit = Range -> Text -> TextEdit
LSP.TextEdit (Position -> Position -> Range
LSP.Range Position
startPos Position
startPos{ LSP._character = startCol + fromIntegral newLineCol }) Text
""
  , let insertPosition :: Position
insertPosition = UInt -> UInt -> Position
LSP.Position (UInt
startLine UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) UInt
0
  , let insertRange :: Range
insertRange = Position -> Position -> Range
LSP.Range Position
insertPosition Position
insertPosition
  , let insertText :: Text
insertText = [Char] -> Text
Text.pack (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
List.take Int
newLineCol [Char]
tokenString) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  , let insertTextEdit :: TextEdit
insertTextEdit = Range -> Text -> TextEdit
LSP.TextEdit Range
insertRange Text
insertText
  = TextEdit -> TextEdit -> LineSplitTextEdits
LineSplitTextEdits TextEdit
insertTextEdit TextEdit
deleteTextEdit
  where
    LSP.Range (LSP.Position UInt
startLine UInt
startCol) (LSP.Position UInt
endLine UInt
endCol) = Range
tokenRange

    newLineCol :: Int
newLineCol = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Maybe.fromMaybe ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
tokenString) (Char -> [Char] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Char
'\n' [Char]
tokenString)

-- ITvarsym "#" after a block comment is a parse error so we don't need to worry about it
updateParserState :: Token -> LSP.Range -> ParserState -> ParserState
updateParserState :: Token -> Range -> ParserState -> ParserState
updateParserState Token
token Range
range ParserState
prevParserState
  | ParserStateNotDone
      { $sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
nextPragma = prevNextPragma :: NextPragmaInfo
prevNextPragma@NextPragmaInfo{ $sel:lineSplitTextEdits:NextPragmaInfo :: NextPragmaInfo -> Maybe LineSplitTextEdits
lineSplitTextEdits = Maybe LineSplitTextEdits
prevLineSplitTextEdits }
      , $sel:mode:ParserStateNotDone :: ParserState -> Mode
mode = Mode
prevMode
      , Int
$sel:lastBlockCommentLine:ParserStateNotDone :: ParserState -> Int
lastBlockCommentLine :: Int
lastBlockCommentLine
      , Int
$sel:lastPragmaLine:ParserStateNotDone :: ParserState -> Int
lastPragmaLine :: Int
lastPragmaLine
      } <- ParserState
prevParserState
  , let defaultParserState :: ParserState
defaultParserState = ParserState
prevParserState { isLastTokenHash = False }
  , let LSP.Range (LSP.Position (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
startLine) UInt
_) (LSP.Position (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
endLine) UInt
_) = Range
range
  = case Mode
prevMode of
      Mode
ModeInitial ->
        case Token
token of
          ITvarsym FastString
"#" -> ParserState
defaultParserState{ isLastTokenHash = True }
          ITlineComment [Char]
s PsSpan
_
            | [Char] -> Bool
isDownwardLineHaddock [Char]
s -> ParserState
defaultParserState{ mode = ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState
                  { nextPragma = NextPragmaInfo (endLine + 1) Nothing
                  , mode = ModeComment }
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState
                  { nextPragma = NextPragmaInfo (endLine + 1) Nothing
                  , mode = ModePragma
                  , lastPragmaLine = endLine }
            | [Char] -> Bool
isDownwardBlockHaddock [Char]
s -> ParserState
defaultParserState{ mode = ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState
                  { nextPragma = NextPragmaInfo (endLine + 1) Nothing
                  , mode = ModeComment
                  , lastBlockCommentLine = endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
      Mode
ModeComment ->
        case Token
token of
          ITvarsym FastString
"#" -> ParserState
defaultParserState{ isLastTokenHash = True }
          ITlineComment [Char]
s PsSpan
_
            | Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
startLine Maybe LineSplitTextEdits
prevLineSplitTextEdits
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
prevLineSplitTextEdits ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardLineHaddock [Char]
s
            , Int
lastBlockCommentLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
forall a. Maybe a
Nothing ->
                ParserState
defaultParserState
                  { nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits }
                  , mode = ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing }
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState
                  { nextPragma = NextPragmaInfo (endLine + 1) Nothing
                  , mode = ModePragma
                  , lastPragmaLine = endLine }
            | Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
startLine Maybe LineSplitTextEdits
prevLineSplitTextEdits
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
prevLineSplitTextEdits ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardBlockHaddock [Char]
s
            , Int
lastBlockCommentLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{
                  nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits },
                  mode = ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState{
                  nextPragma = NextPragmaInfo (endLine + 1) Nothing,
                  lastBlockCommentLine = endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
      Mode
ModeHaddock ->
        case Token
token of
          ITvarsym FastString
"#" ->
            ParserState
defaultParserState{ isLastTokenHash = True }
          ITlineComment [Char]
s PsSpan
_
            | Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
startLine Maybe LineSplitTextEdits
prevLineSplitTextEdits
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
prevLineSplitTextEdits ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | Bool
otherwise ->
                ParserState
defaultParserState
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState{
                  nextPragma = NextPragmaInfo (endLine + 1) Nothing,
                  mode = ModePragma,
                  lastPragmaLine = endLine }
            | Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
startLine Maybe LineSplitTextEdits
prevLineSplitTextEdits
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
prevLineSplitTextEdits ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | Bool
otherwise -> ParserState
defaultParserState{ lastBlockCommentLine = endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
      Mode
ModePragma ->
        case Token
token of
          ITvarsym FastString
"#" -> ParserState
defaultParserState{ isLastTokenHash = True }
          ITlineComment [Char]
s PsSpan
_
            | Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
startLine Maybe LineSplitTextEdits
prevLineSplitTextEdits
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
prevLineSplitTextEdits ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardLineHaddock [Char]
s
            , Int
lastPragmaLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | Bool
otherwise ->
                ParserState
defaultParserState
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState{ nextPragma = NextPragmaInfo (endLine + 1) Nothing, lastPragmaLine = endLine }
            | Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
startLine Maybe LineSplitTextEdits
prevLineSplitTextEdits
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
prevLineSplitTextEdits ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardBlockHaddock [Char]
s
            , Int
lastPragmaLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | Int
lastPragmaLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
startLine Bool -> Bool -> Bool
&& Int
startLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
endLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s Maybe LineSplitTextEdits
forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } }
            | Bool
otherwise ->
                ParserState
defaultParserState{ lastBlockCommentLine = endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
  | Bool
otherwise = ParserState
prevParserState
  where
    hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool
    hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool
hasDeleteStartedOnSameLine Int
line Maybe LineSplitTextEdits
mbLineSplitTextEdits
      | Just LineSplitTextEdits
lineSplitTextEdits <- Maybe LineSplitTextEdits
mbLineSplitTextEdits
      , let LineSplitTextEdits{ TextEdit
$sel:lineSplitDeleteTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> TextEdit
lineSplitDeleteTextEdit :: TextEdit
lineSplitDeleteTextEdit } = LineSplitTextEdits
lineSplitTextEdits
      , let LSP.TextEdit Range
deleteRange Text
_ = TextEdit
lineSplitDeleteTextEdit
      , let LSP.Range Position
_ Position
deleteEndPosition = Range
deleteRange
      , let LSP.Position UInt
deleteEndLine UInt
_ = Position
deleteEndPosition
      = UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
deleteEndLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line
      | Bool
otherwise = Bool
False

lexUntilNextLineIncl :: P (Located Token)
lexUntilNextLineIncl :: P (Located Token)
lexUntilNextLineIncl = do
  PState{ PsSpan
last_loc :: PsSpan
last_loc :: PState -> PsSpan
last_loc } <- P PState
getPState
  let PsSpan{ psRealSpan :: PsSpan -> RealSrcSpan
psRealSpan = RealSrcSpan
lastRealSrcSpan } = PsSpan
last_loc
  let prevEndLine :: Int
prevEndLine = RealSrcSpan
lastRealSrcSpan RealSrcSpan -> (RealSrcSpan -> RealSrcLoc) -> RealSrcLoc
forall a b. a -> (a -> b) -> b
& RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcLoc -> (RealSrcLoc -> Int) -> Int
forall a b. a -> (a -> b) -> b
& RealSrcLoc -> Int
srcLocLine
  locatedToken :: Located Token
locatedToken@(L SrcSpan
srcSpan Token
_token) <- Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  if | RealSrcLoc RealSrcLoc
currEndRealSrcLoc Maybe BufPos
_ <- SrcSpan
srcSpan SrcSpan -> (SrcSpan -> SrcLoc) -> SrcLoc
forall a b. a -> (a -> b) -> b
& SrcSpan -> SrcLoc
srcSpanEnd
     , let currEndLine :: Int
currEndLine = RealSrcLoc
currEndRealSrcLoc RealSrcLoc -> (RealSrcLoc -> Int) -> Int
forall a b. a -> (a -> b) -> b
& RealSrcLoc -> Int
srcLocLine
     -> if Int
prevEndLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
currEndLine then
          Located Token -> P (Located Token)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located Token
locatedToken
        else P (Located Token)
lexUntilNextLineIncl
     | Bool
otherwise -> Located Token -> P (Located Token)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located Token
locatedToken

dropWhileStringBuffer :: (Char -> Bool) -> StringBuffer -> StringBuffer
dropWhileStringBuffer :: (Char -> Bool) -> StringBuffer -> StringBuffer
dropWhileStringBuffer Char -> Bool
predicate StringBuffer
buffer
  | StringBuffer -> Bool
atEnd StringBuffer
buffer = StringBuffer
buffer
  | let (Char
c, StringBuffer
remainingBuffer) = StringBuffer -> (Char, StringBuffer)
nextChar StringBuffer
buffer
  = if Char -> Bool
predicate Char
c then
      (Char -> Bool) -> StringBuffer -> StringBuffer
dropWhileStringBuffer Char -> Bool
predicate StringBuffer
remainingBuffer
    else
      StringBuffer
buffer

isHorizontalSpace :: Char -> Bool
isHorizontalSpace :: Char -> Bool
isHorizontalSpace Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'

data ShebangParserState = ShebangParserState {
  ShebangParserState -> Int
nextPragmaLine :: !Int,
  ShebangParserState -> Int
newlineCount   :: !Int,
  ShebangParserState -> Bool
prevCharIsHash :: !Bool,
  ShebangParserState -> StringBuffer
buffer         :: !StringBuffer
}

-- lexer seems to ignore shebangs completely hence this function
parseShebangs :: ShebangParserState -> ShebangParserState
parseShebangs :: ShebangParserState -> ShebangParserState
parseShebangs prev :: ShebangParserState
prev@ShebangParserState{ $sel:newlineCount:ShebangParserState :: ShebangParserState -> Int
newlineCount = Int
prevNewlineCount, Bool
$sel:prevCharIsHash:ShebangParserState :: ShebangParserState -> Bool
prevCharIsHash :: Bool
prevCharIsHash, $sel:buffer:ShebangParserState :: ShebangParserState -> StringBuffer
buffer = StringBuffer
prevBuffer }
  | StringBuffer -> Bool
atEnd StringBuffer
prevBuffer
  = ShebangParserState
prev
  | let (Char
c, StringBuffer
currBuffer) = StringBuffer -> (Char, StringBuffer)
nextChar ((Char -> Bool) -> StringBuffer -> StringBuffer
dropWhileStringBuffer Char -> Bool
isHorizontalSpace StringBuffer
prevBuffer)
  = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' then
      ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
prev{ prevCharIsHash = True, buffer = currBuffer }
    else if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
&& Bool
prevCharIsHash then
      ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
prev{ nextPragmaLine = prevNewlineCount + 1, buffer = dropWhileStringBuffer (/= '\n') currBuffer }
    else if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then
      ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
prev{ newlineCount = prevNewlineCount + 1, buffer = currBuffer }
    else
      ShebangParserState
prev


-- | Parses blank lines, comments, haddock comments ("-- |"), lines that start
-- with "#!", lines that start with "#", pragma lines using the GHC API lexer.
-- When it doesn't find one of these things then it's assumed that we've found
-- a declaration, end-of-file, or a ghc parse error, and the parser stops.
-- Shebangs are parsed separately than the rest becaues the lexer ignores them.
--
-- The reason for custom parsing instead of using annotations, or turning on/off
-- extensions in the dynflags is because there are a number of extensions that
-- while removing parse errors, can also introduce them. Hence, there are
-- cases where the file cannot be parsed without error when we want to insert
-- extension (and other) pragmas. The compiler (8.10.7) doesn't include
-- annotations in its failure state. So if the compiler someday returns
-- annotation or equivalent information when it fails then we can replace this
-- with that.
--
-- The reason for using the compiler lexer is to reduce duplicated
-- implementation, particularly nested comments, but in retrospect this comes
-- with the disadvantage of the logic feeling more complex, and not being able
-- to handle whitespace directly.
--
-- The parser keeps track of state in order to place the next pragma line
-- according to some rules:
--
-- - Ignore lines starting with '#' except for shebangs.
-- - If pragmas exist place after last pragma
-- - else if haddock comments exist:
--     - If comments exist place after last comment
--     - else if shebangs exist place after last shebang
--     - else place at first line
-- - else if comments exist place after last comment
-- - else if shebangs exist place after last shebang
-- - else place at first line
--
-- Additionally the parser keeps track of information to be able to insert
-- pragmas inbetween lines.
--
-- For example the parser keeps track of information so that
--
-- > {- block comment -} -- | haddock
--
-- can become
--
-- > {- block comment -}
-- > {-# pragma #-}
-- > -- | haddock
--
-- This information does not respect the type of whitespace, because the lexer
-- strips whitespace and gives locations.
--
-- In this example the tabs are converted to spaces in the TextEdits:
--
-- > {- block comment -}<space><tab><tab><space>-- | haddock
--
parsePreDecl :: DynFlags -> StringBuffer -> ParseResult ParserState
parsePreDecl :: DynFlags -> StringBuffer -> ParseResult ParserState
parsePreDecl DynFlags
dynFlags StringBuffer
buffer = P ParserState -> PState -> ParseResult ParserState
forall a. P a -> PState -> ParseResult a
unP (ParserState -> P ParserState
go ParserState
initialParserState) PState
pState
  where
    initialShebangParserState :: ShebangParserState
initialShebangParserState = ShebangParserState{
      $sel:nextPragmaLine:ShebangParserState :: Int
nextPragmaLine = Int
0,
      $sel:newlineCount:ShebangParserState :: Int
newlineCount = Int
0,
      $sel:prevCharIsHash:ShebangParserState :: Bool
prevCharIsHash = Bool
False,
      $sel:buffer:ShebangParserState :: StringBuffer
buffer = StringBuffer
buffer }
    ShebangParserState{ Int
$sel:nextPragmaLine:ShebangParserState :: ShebangParserState -> Int
nextPragmaLine :: Int
nextPragmaLine } = ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
initialShebangParserState
    pState :: PState
pState = DynFlags -> StringBuffer -> PState
mkLexerPState DynFlags
dynFlags StringBuffer
buffer
    initialParserState :: ParserState
initialParserState = NextPragmaInfo -> Mode -> Int -> Int -> Bool -> ParserState
ParserStateNotDone (Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo Int
nextPragmaLine Maybe LineSplitTextEdits
forall a. Maybe a
Nothing) Mode
ModeInitial (-Int
1) (-Int
1) Bool
False

    go :: ParserState -> P ParserState
    go :: ParserState -> P ParserState
go ParserState
prevParserState =
      case ParserState
prevParserState of
        ParserStateDone NextPragmaInfo
_ -> ParserState -> P ParserState
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParserState
prevParserState
        ParserStateNotDone{Bool
Int
NextPragmaInfo
Mode
$sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
$sel:mode:ParserStateNotDone :: ParserState -> Mode
$sel:lastBlockCommentLine:ParserStateNotDone :: ParserState -> Int
$sel:lastPragmaLine:ParserStateNotDone :: ParserState -> Int
$sel:isLastTokenHash:ParserStateNotDone :: ParserState -> Bool
nextPragma :: NextPragmaInfo
mode :: Mode
lastBlockCommentLine :: Int
lastPragmaLine :: Int
isLastTokenHash :: Bool
..} -> do
          L SrcSpan
srcSpan Token
token <-
            if Bool
isLastTokenHash then
              P (Located Token)
lexUntilNextLineIncl
            else
              Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          case SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
srcSpan of
            Just Range
range -> ParserState -> P ParserState
go (Token -> Range -> ParserState -> ParserState
updateParserState Token
token Range
range ParserState
prevParserState)
            Maybe Range
Nothing    -> ParserState -> P ParserState
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParserState
prevParserState

mkLexerPState :: DynFlags -> StringBuffer -> PState
mkLexerPState :: DynFlags -> StringBuffer -> PState
mkLexerPState DynFlags
dynFlags StringBuffer
stringBuffer =
  let
    startRealSrcLoc :: RealSrcLoc
startRealSrcLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
"asdf" Int
1 Int
1
    updateDynFlags :: DynFlags -> DynFlags
updateDynFlags = (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_Haddock (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_set GeneralFlag
Opt_KeepRawTokenStream
    finalDynFlags :: DynFlags
finalDynFlags = DynFlags -> DynFlags
updateDynFlags DynFlags
dynFlags
    pState :: PState
pState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
finalDynFlags) StringBuffer
stringBuffer RealSrcLoc
startRealSrcLoc
    PState{ options :: PState -> ParserOpts
options = ParserOpts
pStateOptions } = PState
pState
    finalExtBitsMap :: ExtsBitmap
finalExtBitsMap = ExtsBitmap -> Int -> ExtsBitmap
forall a. Bits a => a -> Int -> a
setBit (ParserOpts -> ExtsBitmap
pExtsBitmap ParserOpts
pStateOptions) (ExtBits -> Int
forall a. Enum a => a -> Int
fromEnum ExtBits
UsePosPragsBit)
    finalPStateOptions :: ParserOpts
finalPStateOptions = ParserOpts
pStateOptions{ pExtsBitmap = finalExtBitsMap }
    finalPState :: PState
finalPState = PState
pState{ options = finalPStateOptions }
  in
    PState
finalPState