{-# 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
$sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
nextPragma :: NextPragmaInfo
nextPragma } -> NextPragmaInfo
nextPragma
         ParserStateDone{ NextPragmaInfo
nextPragma :: NextPragmaInfo
$sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
nextPragma }    -> NextPragmaInfo
nextPragma
     | Bool
otherwise
     -> Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo Int
0 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 (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 forall a b. a -> (a -> b) -> b
& forall s a. HasNewText s a => Lens' s a
L.newText forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"{-# LANGUAGE " forall a. Semigroup a => a -> a -> a
<> Extension -> Text
showExtension Extension
newPragma 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 forall a b. (a -> b) -> a -> b
$ Text
"{-# LANGUAGE " forall a. Semigroup a => a -> a -> a
<> Extension -> Text
showExtension Extension
newPragma forall a. Semigroup a => a -> a -> a
<> Text
" #-}\n"
    where
        pragmaInsertPosition :: Position
pragmaInsertPosition = UInt -> UInt -> Position
LSP.Position (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
_) <- forall (m :: * -> *) e a.
MonadIO m =>
[Char] -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (Text -> [Char]
T.unpack Text
pId forall a. Semigroup a => a -> a -> a
<> [Char]
".GhcSession") IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
nfp
  (UTCTime
_, Maybe Text
fileContents) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> IdeState -> Action a -> IO a
runAction (Text -> [Char]
T.unpack Text
pId forall a. Semigroup a => a -> a -> a
<> [Char]
".GetFileContents") IdeState
state forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> ShowS
[Mode] -> ShowS
Mode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> [Char]
$cshow :: Mode -> [Char]
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show

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

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

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

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

isDownwardLineHaddock :: String -> Bool
isDownwardLineHaddock :: [Char] -> Bool
isDownwardLineHaddock = 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 =
          Text -> Text
Text.init Text
prevInsertText
          forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
startCol forall a. Num a => a -> a -> a
- UInt
prevDeleteEndCol) Text
" "
          forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Int -> [a] -> [a]
List.take Int
newLineCol [Char]
tokenString)
          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{ $sel:_character:Position :: UInt
LSP._character = UInt
startCol forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
newLineCol }) Text
""
  , let insertPosition :: Position
insertPosition = UInt -> UInt -> Position
LSP.Position (UInt
startLine 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 (forall a. Int -> [a] -> [a]
List.take Int
newLineCol [Char]
tokenString) 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 = forall a. a -> Maybe a -> a
Maybe.fromMaybe (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
tokenString) (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
lastBlockCommentLine :: Int
$sel:lastBlockCommentLine:ParserStateNotDone :: ParserState -> Int
lastBlockCommentLine
      , Int
lastPragmaLine :: Int
$sel:lastPragmaLine:ParserStateNotDone :: ParserState -> Int
lastPragmaLine
      } <- ParserState
prevParserState
  , let defaultParserState :: ParserState
defaultParserState = ParserState
prevParserState { $sel:isLastTokenHash:ParserStateNotDone :: Bool
isLastTokenHash = Bool
False }
  , let LSP.Range (LSP.Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
startLine) UInt
_) (LSP.Position (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{ $sel:isLastTokenHash:ParserStateNotDone :: Bool
isLastTokenHash = Bool
True }
          ITlineComment [Char]
s PsSpan
_
            | [Char] -> Bool
isDownwardLineHaddock [Char]
s -> ParserState
defaultParserState{ $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState
                  { $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing
                  , $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModeComment }
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState
                  { $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing
                  , $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModePragma
                  , $sel:lastPragmaLine:ParserStateNotDone :: Int
lastPragmaLine = Int
endLine }
            | [Char] -> Bool
isDownwardBlockHaddock [Char]
s -> ParserState
defaultParserState{ $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState
                  { $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing
                  , $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModeComment
                  , $sel:lastBlockCommentLine:ParserStateNotDone :: Int
lastBlockCommentLine = Int
endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
      Mode
ModeComment ->
        case Token
token of
          ITvarsym FastString
"#" -> ParserState
defaultParserState{ $sel:isLastTokenHash:ParserStateNotDone :: Bool
isLastTokenHash = Bool
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{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardLineHaddock [Char]
s
            , Int
lastBlockCommentLine forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s forall a. Maybe a
Nothing ->
                ParserState
defaultParserState
                  { $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits }
                  , $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState { $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing }
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState
                  { $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing
                  , $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModePragma
                  , $sel:lastPragmaLine:ParserStateNotDone :: Int
lastPragmaLine = Int
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{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardBlockHaddock [Char]
s
            , Int
lastBlockCommentLine forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{
                  $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits },
                  $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModeHaddock }
            | Bool
otherwise ->
                ParserState
defaultParserState{
                  $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing,
                  $sel:lastBlockCommentLine:ParserStateNotDone :: Int
lastBlockCommentLine = Int
endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
      Mode
ModeHaddock ->
        case Token
token of
          ITvarsym FastString
"#" ->
            ParserState
defaultParserState{ $sel:isLastTokenHash:ParserStateNotDone :: Bool
isLastTokenHash = Bool
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{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | Bool
otherwise ->
                ParserState
defaultParserState
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState{
                  $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing,
                  $sel:mode:ParserStateNotDone :: Mode
mode = Mode
ModePragma,
                  $sel:lastPragmaLine:ParserStateNotDone :: Int
lastPragmaLine = Int
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{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | Bool
otherwise -> ParserState
defaultParserState{ $sel:lastBlockCommentLine:ParserStateNotDone :: Int
lastBlockCommentLine = Int
endLine }
          Token
_ -> NextPragmaInfo -> ParserState
ParserStateDone NextPragmaInfo
prevNextPragma
      Mode
ModePragma ->
        case Token
token of
          ITvarsym FastString
"#" -> ParserState
defaultParserState{ $sel:isLastTokenHash:ParserStateNotDone :: Bool
isLastTokenHash = Bool
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{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardLineHaddock [Char]
s
            , Int
lastPragmaLine forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | Bool
otherwise ->
                ParserState
defaultParserState
          ITblockComment [Char]
s PsSpan
_
            | [Char] -> Bool
isPragma [Char]
s ->
                ParserState
defaultParserState{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = Int -> Maybe LineSplitTextEdits -> NextPragmaInfo
NextPragmaInfo (Int
endLine forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing, $sel:lastPragmaLine:ParserStateNotDone :: Int
lastPragmaLine = Int
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{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | [Char] -> Bool
isDownwardBlockHaddock [Char]
s
            , Int
lastPragmaLine forall a. Eq a => a -> a -> Bool
== Int
startLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | Int
lastPragmaLine forall a. Eq a => a -> a -> Bool
== Int
startLine Bool -> Bool -> Bool
&& Int
startLine forall a. Ord a => a -> a -> Bool
< Int
endLine
            , let currLineSplitTextEdits :: LineSplitTextEdits
currLineSplitTextEdits = Range -> [Char] -> Maybe LineSplitTextEdits -> LineSplitTextEdits
updateLineSplitTextEdits Range
range [Char]
s forall a. Maybe a
Nothing ->
                ParserState
defaultParserState{ $sel:nextPragma:ParserStateNotDone :: NextPragmaInfo
nextPragma = NextPragmaInfo
prevNextPragma{ $sel:lineSplitTextEdits:NextPragmaInfo :: Maybe LineSplitTextEdits
lineSplitTextEdits = forall a. a -> Maybe a
Just LineSplitTextEdits
currLineSplitTextEdits } }
            | Bool
otherwise ->
                ParserState
defaultParserState{ $sel:lastBlockCommentLine:ParserStateNotDone :: Int
lastBlockCommentLine = Int
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
lineSplitDeleteTextEdit :: TextEdit
$sel:lineSplitDeleteTextEdit:LineSplitTextEdits :: LineSplitTextEdits -> 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
      = forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
deleteEndLine 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 :: PState -> PsSpan
last_loc :: PsSpan
last_loc } <- P PState
getPState
  let PsSpan{ psRealSpan :: PsSpan -> RealSrcSpan
psRealSpan = RealSrcSpan
lastRealSrcSpan } = PsSpan
last_loc
  let prevEndLine :: Int
prevEndLine = RealSrcSpan
lastRealSrcSpan forall a b. a -> (a -> b) -> b
& RealSrcSpan -> RealSrcLoc
realSrcSpanEnd forall a b. a -> (a -> b) -> b
& RealSrcLoc -> Int
srcLocLine
  locatedToken :: Located Token
locatedToken@(L SrcSpan
srcSpan Token
_token) <- forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False forall (f :: * -> *) a. Applicative f => a -> f a
pure
  if | RealSrcLoc RealSrcLoc
currEndRealSrcLoc Maybe BufPos
_ <- SrcSpan
srcSpan forall a b. a -> (a -> b) -> b
& SrcSpan -> SrcLoc
srcSpanEnd
     , let currEndLine :: Int
currEndLine = RealSrcLoc
currEndRealSrcLoc forall a b. a -> (a -> b) -> b
& RealSrcLoc -> Int
srcLocLine
     -> if Int
prevEndLine forall a. Ord a => a -> a -> Bool
< Int
currEndLine then
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Located Token
locatedToken
        else P (Located Token)
lexUntilNextLineIncl
     | Bool
otherwise -> 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 forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c 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
prevCharIsHash :: Bool
$sel:prevCharIsHash:ShebangParserState :: ShebangParserState -> 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 forall a. Eq a => a -> a -> Bool
== Char
'#' then
      ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
prev{ $sel:prevCharIsHash:ShebangParserState :: Bool
prevCharIsHash = Bool
True, $sel:buffer:ShebangParserState :: StringBuffer
buffer = StringBuffer
currBuffer }
    else if Char
c forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
&& Bool
prevCharIsHash then
      ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
prev{ $sel:nextPragmaLine:ShebangParserState :: Int
nextPragmaLine = Int
prevNewlineCount forall a. Num a => a -> a -> a
+ Int
1, $sel:buffer:ShebangParserState :: StringBuffer
buffer = (Char -> Bool) -> StringBuffer -> StringBuffer
dropWhileStringBuffer (forall a. Eq a => a -> a -> Bool
/= Char
'\n') StringBuffer
currBuffer }
    else if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n' then
      ShebangParserState -> ShebangParserState
parseShebangs ShebangParserState
prev{ $sel:newlineCount:ShebangParserState :: Int
newlineCount = Int
prevNewlineCount forall a. Num a => a -> a -> a
+ Int
1, $sel:buffer:ShebangParserState :: StringBuffer
buffer = StringBuffer
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 = 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
nextPragmaLine :: Int
$sel:nextPragmaLine:ShebangParserState :: ShebangParserState -> 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 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ParserState
prevParserState
        ParserStateNotDone{Bool
Int
NextPragmaInfo
Mode
isLastTokenHash :: Bool
lastPragmaLine :: Int
lastBlockCommentLine :: Int
mode :: Mode
nextPragma :: NextPragmaInfo
$sel:isLastTokenHash:ParserStateNotDone :: ParserState -> Bool
$sel:lastPragmaLine:ParserStateNotDone :: ParserState -> Int
$sel:lastBlockCommentLine:ParserStateNotDone :: ParserState -> Int
$sel:mode:ParserStateNotDone :: ParserState -> Mode
$sel:nextPragma:ParserStateNotDone :: ParserState -> NextPragmaInfo
..} -> do
          L SrcSpan
srcSpan Token
token <-
            if Bool
isLastTokenHash then
              P (Located Token)
lexUntilNextLineIncl
            else
              forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False 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    -> 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_Haddock forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Bits a => a -> Int -> a
setBit (ParserOpts -> ExtsBitmap
pExtsBitmap ParserOpts
pStateOptions) (forall a. Enum a => a -> Int
fromEnum ExtBits
UsePosPragsBit)
    finalPStateOptions :: ParserOpts
finalPStateOptions = ParserOpts
pStateOptions{ pExtsBitmap :: ExtsBitmap
pExtsBitmap = ExtsBitmap
finalExtBitsMap }
    finalPState :: PState
finalPState = PState
pState{ options :: ParserOpts
options = ParserOpts
finalPStateOptions }
  in
    PState
finalPState