-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0


-- | Types and functions for working with source code locations.
module Development.IDE.Types.Location
    ( Location(..)
    , noFilePath
    , noRange
    , Position(..)
    , showPosition
    , Range(..)
    , LSP.Uri(..)
    , LSP.NormalizedUri
    , LSP.toNormalizedUri
    , LSP.fromNormalizedUri
    , LSP.NormalizedFilePath
    , fromUri
    , emptyFilePath
    , emptyPathUri
    , toNormalizedFilePath'
    , LSP.fromNormalizedFilePath
    , filePathToUri'
    , uriToFilePath'
    , readSrcSpan
    ) where

import Control.Applicative
import Language.LSP.Types (Location(..), Range(..), Position(..))
import Control.Monad
import Data.Hashable (Hashable(hash))
import Data.String
import FastString
import qualified Language.LSP.Types as LSP
import SrcLoc as GHC
import Text.ParserCombinators.ReadP as ReadP
import Data.Maybe (fromMaybe)

toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
-- We want to keep empty paths instead of normalising them to "."
toNormalizedFilePath' :: FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
"" = NormalizedFilePath
emptyFilePath
toNormalizedFilePath' FilePath
fp = FilePath -> NormalizedFilePath
LSP.toNormalizedFilePath FilePath
fp

emptyFilePath :: LSP.NormalizedFilePath
emptyFilePath :: NormalizedFilePath
emptyFilePath = NormalizedUri -> FilePath -> NormalizedFilePath
LSP.NormalizedFilePath NormalizedUri
emptyPathUri FilePath
""

-- | We use an empty string as a filepath when we don’t have a file.
-- However, haskell-lsp doesn’t support that in uriToFilePath and given
-- that it is not a valid filepath it does not make sense to upstream a fix.
-- So we have our own wrapper here that supports empty filepaths.
uriToFilePath' :: LSP.Uri -> Maybe FilePath
uriToFilePath' :: Uri -> Maybe FilePath
uriToFilePath' Uri
uri
    | Uri
uri Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedUri -> Uri
LSP.fromNormalizedUri NormalizedUri
emptyPathUri = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
""
    | Bool
otherwise = Uri -> Maybe FilePath
LSP.uriToFilePath Uri
uri

emptyPathUri :: LSP.NormalizedUri
emptyPathUri :: NormalizedUri
emptyPathUri =
    let s :: Text
s = Text
"file://"
    in Int -> Text -> NormalizedUri
LSP.NormalizedUri (Text -> Int
forall a. Hashable a => a -> Int
hash Text
s) Text
s

filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
filePathToUri' :: NormalizedFilePath -> NormalizedUri
filePathToUri' = NormalizedFilePath -> NormalizedUri
LSP.normalizedFilePathToUri

fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
fromUri :: NormalizedUri -> NormalizedFilePath
fromUri = NormalizedFilePath
-> Maybe NormalizedFilePath -> NormalizedFilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
noFilePath) (Maybe NormalizedFilePath -> NormalizedFilePath)
-> (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri
-> NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> Maybe NormalizedFilePath
LSP.uriToNormalizedFilePath

noFilePath :: FilePath
noFilePath :: FilePath
noFilePath = FilePath
"<unknown>"

-- A dummy range to use when range is unknown
noRange :: Range
noRange :: Range
noRange =  Position -> Position -> Range
Range (Int -> Int -> Position
Position Int
0 Int
0) (Int -> Int -> Position
Position Int
1 Int
0)

showPosition :: Position -> String
showPosition :: Position -> FilePath
showPosition Position{Int
_line :: Position -> Int
_character :: Position -> Int
_character :: Int
_line :: Int
..} = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
_line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
_character Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- | Parser for the GHC output format
readSrcSpan :: ReadS RealSrcSpan
readSrcSpan :: ReadS RealSrcSpan
readSrcSpan = ReadP RealSrcSpan -> ReadS RealSrcSpan
forall a. ReadP a -> ReadS a
readP_to_S (ReadP RealSrcSpan
singleLineSrcSpanP ReadP RealSrcSpan -> ReadP RealSrcSpan -> ReadP RealSrcSpan
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP RealSrcSpan
multiLineSrcSpanP)
  where
    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan
    singleLineSrcSpanP :: ReadP RealSrcSpan
singleLineSrcSpanP = do
      FastString
fp <- ReadP FastString
filePathP
      Int
l  <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads ReadP Int -> ReadP Char -> ReadP Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
':'
      Int
c0 <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads
      Int
c1 <- (Char -> ReadP Char
char Char
'-' ReadP Char -> ReadP Int -> ReadP Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads) ReadP Int -> ReadP Int -> ReadP Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> ReadP Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
c0
      let from :: RealSrcLoc
from = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fp Int
l Int
c0
          to :: RealSrcLoc
to   = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fp Int
l Int
c1
      RealSrcSpan -> ReadP RealSrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> ReadP RealSrcSpan)
-> RealSrcSpan -> ReadP RealSrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
from RealSrcLoc
to

    multiLineSrcSpanP :: ReadP RealSrcSpan
multiLineSrcSpanP = do
      FastString
fp <- ReadP FastString
filePathP
      RealSrcLoc
s <- ReadP RealSrcLoc -> ReadP RealSrcLoc
forall a. ReadP a -> ReadP a
parensP (FastString -> ReadP RealSrcLoc
srcLocP FastString
fp)
      ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
'-'
      RealSrcLoc
e <- ReadP RealSrcLoc -> ReadP RealSrcLoc
forall a. ReadP a -> ReadP a
parensP (FastString -> ReadP RealSrcLoc
srcLocP FastString
fp)
      RealSrcSpan -> ReadP RealSrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> ReadP RealSrcSpan)
-> RealSrcSpan -> ReadP RealSrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
s RealSrcLoc
e

    parensP :: ReadP a -> ReadP a
    parensP :: ReadP a -> ReadP a
parensP = ReadP Char -> ReadP Char -> ReadP a -> ReadP a
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')')

    filePathP :: ReadP FastString
    filePathP :: ReadP FastString
filePathP = FilePath -> FastString
forall a. IsString a => FilePath -> a
fromString (FilePath -> FastString) -> ReadP FilePath -> ReadP FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP FilePath
readFilePath ReadP FilePath -> ReadP Char -> ReadP FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
':') ReadP FastString -> ReadP FastString -> ReadP FastString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FastString -> ReadP FastString
forall (f :: * -> *) a. Applicative f => a -> f a
pure FastString
""

    srcLocP :: FastString -> ReadP RealSrcLoc
    srcLocP :: FastString -> ReadP RealSrcLoc
srcLocP FastString
fp = do
      Int
l <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads
      ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
','
      Int
c <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads
      RealSrcLoc -> ReadP RealSrcLoc
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcLoc -> ReadP RealSrcLoc) -> RealSrcLoc -> ReadP RealSrcLoc
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fp Int
l Int
c

    readFilePath :: ReadP FilePath
    readFilePath :: ReadP FilePath
readFilePath = ReadP Char -> ReadP FilePath
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReadP Char
ReadP.get