-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-}


-- | 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           Control.Monad
import           Data.Hashable                (Hashable (hash))
import           Data.Maybe                   (fromMaybe)
import           Data.String

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Data.FastString
import           GHC.Types.SrcLoc             as GHC
#else
import           FastString
import           SrcLoc                       as GHC
#endif
import           Language.LSP.Types           (Location (..), Position (..),
                                               Range (..))
import qualified Language.LSP.Types           as LSP
import           Text.ParserCombinators.ReadP as ReadP

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
#if MIN_VERSION_lsp_types(1,3,0)
emptyFilePath :: NormalizedFilePath
emptyFilePath = NormalizedUri -> FilePath -> NormalizedFilePath
LSP.normalizedFilePath NormalizedUri
emptyPathUri FilePath
""
#else
emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""
#endif

-- | 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 (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
1 UInt
0)

showPosition :: Position -> String
showPosition :: Position -> FilePath
showPosition Position{UInt
_line :: Position -> UInt
_character :: Position -> UInt
_character :: UInt
_line :: UInt
..} = UInt -> FilePath
forall a. Show a => a -> FilePath
show (UInt
_line UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UInt -> FilePath
forall a. Show a => a -> FilePath
show (UInt
_character UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
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