{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeSynonymInstances       #-}

module Language.LSP.Types.Uri
  ( Uri(..)
  , uriToFilePath
  , filePathToUri
  , NormalizedUri(..)
  , toNormalizedUri
  , fromNormalizedUri
  , NormalizedFilePath
  , toNormalizedFilePath
  , fromNormalizedFilePath
  , normalizedFilePathToUri
  , uriToNormalizedFilePath
  , emptyNormalizedFilePath
  -- Private functions
  , platformAwareUriToFilePath
  , platformAwareFilePathToUri
  )
  where

import           Control.DeepSeq
import qualified Data.Aeson              as A
import           Data.Binary             (Binary, Get, get, put)
import           Data.Hashable
import           Data.List               (stripPrefix)
import           Data.String             (IsString (fromString))
import           Data.Text               (Text)
import qualified Data.Text               as T
import           GHC.Generics
import           Network.URI             hiding (authority)
import           Safe                    (tailMay)
import qualified System.FilePath         as FP
import qualified System.FilePath.Posix   as FPP
import qualified System.FilePath.Windows as FPW
import qualified System.Info

newtype Uri = Uri { Uri -> Text
getUri :: Text }
  deriving (Uri -> Uri -> Bool
(Uri -> Uri -> Bool) -> (Uri -> Uri -> Bool) -> Eq Uri
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Uri -> Uri -> Bool
== :: Uri -> Uri -> Bool
$c/= :: Uri -> Uri -> Bool
/= :: Uri -> Uri -> Bool
Eq,Eq Uri
Eq Uri =>
(Uri -> Uri -> Ordering)
-> (Uri -> Uri -> Bool)
-> (Uri -> Uri -> Bool)
-> (Uri -> Uri -> Bool)
-> (Uri -> Uri -> Bool)
-> (Uri -> Uri -> Uri)
-> (Uri -> Uri -> Uri)
-> Ord Uri
Uri -> Uri -> Bool
Uri -> Uri -> Ordering
Uri -> Uri -> Uri
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Uri -> Uri -> Ordering
compare :: Uri -> Uri -> Ordering
$c< :: Uri -> Uri -> Bool
< :: Uri -> Uri -> Bool
$c<= :: Uri -> Uri -> Bool
<= :: Uri -> Uri -> Bool
$c> :: Uri -> Uri -> Bool
> :: Uri -> Uri -> Bool
$c>= :: Uri -> Uri -> Bool
>= :: Uri -> Uri -> Bool
$cmax :: Uri -> Uri -> Uri
max :: Uri -> Uri -> Uri
$cmin :: Uri -> Uri -> Uri
min :: Uri -> Uri -> Uri
Ord,ReadPrec [Uri]
ReadPrec Uri
Int -> ReadS Uri
ReadS [Uri]
(Int -> ReadS Uri)
-> ReadS [Uri] -> ReadPrec Uri -> ReadPrec [Uri] -> Read Uri
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Uri
readsPrec :: Int -> ReadS Uri
$creadList :: ReadS [Uri]
readList :: ReadS [Uri]
$creadPrec :: ReadPrec Uri
readPrec :: ReadPrec Uri
$creadListPrec :: ReadPrec [Uri]
readListPrec :: ReadPrec [Uri]
Read,Int -> Uri -> ShowS
[Uri] -> ShowS
Uri -> SystemOS
(Int -> Uri -> ShowS)
-> (Uri -> SystemOS) -> ([Uri] -> ShowS) -> Show Uri
forall a.
(Int -> a -> ShowS) -> (a -> SystemOS) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Uri -> ShowS
showsPrec :: Int -> Uri -> ShowS
$cshow :: Uri -> SystemOS
show :: Uri -> SystemOS
$cshowList :: [Uri] -> ShowS
showList :: [Uri] -> ShowS
Show,(forall x. Uri -> Rep Uri x)
-> (forall x. Rep Uri x -> Uri) -> Generic Uri
forall x. Rep Uri x -> Uri
forall x. Uri -> Rep Uri x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Uri -> Rep Uri x
from :: forall x. Uri -> Rep Uri x
$cto :: forall x. Rep Uri x -> Uri
to :: forall x. Rep Uri x -> Uri
Generic,Maybe Uri
Value -> Parser [Uri]
Value -> Parser Uri
(Value -> Parser Uri)
-> (Value -> Parser [Uri]) -> Maybe Uri -> FromJSON Uri
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Uri
parseJSON :: Value -> Parser Uri
$cparseJSONList :: Value -> Parser [Uri]
parseJSONList :: Value -> Parser [Uri]
$comittedField :: Maybe Uri
omittedField :: Maybe Uri
A.FromJSON,[Uri] -> Encoding
[Uri] -> Value
Uri -> Bool
Uri -> Encoding
Uri -> Value
(Uri -> Value)
-> (Uri -> Encoding)
-> ([Uri] -> Value)
-> ([Uri] -> Encoding)
-> (Uri -> Bool)
-> ToJSON Uri
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Uri -> Value
toJSON :: Uri -> Value
$ctoEncoding :: Uri -> Encoding
toEncoding :: Uri -> Encoding
$ctoJSONList :: [Uri] -> Value
toJSONList :: [Uri] -> Value
$ctoEncodingList :: [Uri] -> Encoding
toEncodingList :: [Uri] -> Encoding
$comitField :: Uri -> Bool
omitField :: Uri -> Bool
A.ToJSON,Eq Uri
Eq Uri => (Int -> Uri -> Int) -> (Uri -> Int) -> Hashable Uri
Int -> Uri -> Int
Uri -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Uri -> Int
hashWithSalt :: Int -> Uri -> Int
$chash :: Uri -> Int
hash :: Uri -> Int
Hashable,ToJSONKeyFunction [Uri]
ToJSONKeyFunction Uri
ToJSONKeyFunction Uri -> ToJSONKeyFunction [Uri] -> ToJSONKey Uri
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction Uri
toJSONKey :: ToJSONKeyFunction Uri
$ctoJSONKeyList :: ToJSONKeyFunction [Uri]
toJSONKeyList :: ToJSONKeyFunction [Uri]
A.ToJSONKey,FromJSONKeyFunction [Uri]
FromJSONKeyFunction Uri
FromJSONKeyFunction Uri
-> FromJSONKeyFunction [Uri] -> FromJSONKey Uri
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction Uri
fromJSONKey :: FromJSONKeyFunction Uri
$cfromJSONKeyList :: FromJSONKeyFunction [Uri]
fromJSONKeyList :: FromJSONKeyFunction [Uri]
A.FromJSONKey)

instance NFData Uri

-- If you care about performance then you should use a hash map. The keys
-- are cached in order to make hashing very fast.
data NormalizedUri = NormalizedUri !Int !Text
  deriving (ReadPrec [NormalizedUri]
ReadPrec NormalizedUri
Int -> ReadS NormalizedUri
ReadS [NormalizedUri]
(Int -> ReadS NormalizedUri)
-> ReadS [NormalizedUri]
-> ReadPrec NormalizedUri
-> ReadPrec [NormalizedUri]
-> Read NormalizedUri
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS NormalizedUri
readsPrec :: Int -> ReadS NormalizedUri
$creadList :: ReadS [NormalizedUri]
readList :: ReadS [NormalizedUri]
$creadPrec :: ReadPrec NormalizedUri
readPrec :: ReadPrec NormalizedUri
$creadListPrec :: ReadPrec [NormalizedUri]
readListPrec :: ReadPrec [NormalizedUri]
Read,Int -> NormalizedUri -> ShowS
[NormalizedUri] -> ShowS
NormalizedUri -> SystemOS
(Int -> NormalizedUri -> ShowS)
-> (NormalizedUri -> SystemOS)
-> ([NormalizedUri] -> ShowS)
-> Show NormalizedUri
forall a.
(Int -> a -> ShowS) -> (a -> SystemOS) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NormalizedUri -> ShowS
showsPrec :: Int -> NormalizedUri -> ShowS
$cshow :: NormalizedUri -> SystemOS
show :: NormalizedUri -> SystemOS
$cshowList :: [NormalizedUri] -> ShowS
showList :: [NormalizedUri] -> ShowS
Show,(forall x. NormalizedUri -> Rep NormalizedUri x)
-> (forall x. Rep NormalizedUri x -> NormalizedUri)
-> Generic NormalizedUri
forall x. Rep NormalizedUri x -> NormalizedUri
forall x. NormalizedUri -> Rep NormalizedUri x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NormalizedUri -> Rep NormalizedUri x
from :: forall x. NormalizedUri -> Rep NormalizedUri x
$cto :: forall x. Rep NormalizedUri x -> NormalizedUri
to :: forall x. Rep NormalizedUri x -> NormalizedUri
Generic, NormalizedUri -> NormalizedUri -> Bool
(NormalizedUri -> NormalizedUri -> Bool)
-> (NormalizedUri -> NormalizedUri -> Bool) -> Eq NormalizedUri
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NormalizedUri -> NormalizedUri -> Bool
== :: NormalizedUri -> NormalizedUri -> Bool
$c/= :: NormalizedUri -> NormalizedUri -> Bool
/= :: NormalizedUri -> NormalizedUri -> Bool
Eq)

-- Slow but compares paths alphabetically as you would expect.
instance Ord NormalizedUri where
  compare :: NormalizedUri -> NormalizedUri -> Ordering
compare (NormalizedUri Int
_ Text
u1) (NormalizedUri Int
_ Text
u2) = Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Text
u1 Text
u2

instance Hashable NormalizedUri where
  hash :: NormalizedUri -> Int
hash (NormalizedUri Int
h Text
_) = Int
h
  hashWithSalt :: Int -> NormalizedUri -> Int
hashWithSalt Int
salt (NormalizedUri Int
h Text
_) = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt Int
h

instance NFData NormalizedUri

isUnescapedInUriPath :: SystemOS -> Char -> Bool
isUnescapedInUriPath :: SystemOS -> Char -> Bool
isUnescapedInUriPath SystemOS
systemOS Char
c
   | SystemOS
systemOS SystemOS -> SystemOS -> Bool
forall a. Eq a => a -> a -> Bool
== SystemOS
windowsOS = Char -> Bool
isUnreserved Char
c Bool -> Bool -> Bool
|| Char
c Char -> SystemOS -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
':', Char
'\\', Char
'/']
   | Bool
otherwise = Char -> Bool
isUnreserved Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'

-- | When URIs are supposed to be used as keys, it is important to normalize
-- the percent encoding in the URI since URIs that only differ
-- when it comes to the percent-encoding should be treated as equivalent.
normalizeUriEscaping :: String -> String
normalizeUriEscaping :: ShowS
normalizeUriEscaping SystemOS
uri =
  case SystemOS -> SystemOS -> Maybe SystemOS
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (SystemOS
fileScheme SystemOS -> ShowS
forall a. [a] -> [a] -> [a]
++ SystemOS
"//") SystemOS
uri of
    Just SystemOS
p  -> SystemOS
fileScheme SystemOS -> ShowS
forall a. [a] -> [a] -> [a]
++ SystemOS
"//" SystemOS -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
escapeURIPath (ShowS
unEscapeString SystemOS
p)
    Maybe SystemOS
Nothing -> (Char -> Bool) -> ShowS
escapeURIString Char -> Bool
isUnescapedInURI ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
unEscapeString SystemOS
uri
  where escapeURIPath :: ShowS
escapeURIPath = (Char -> Bool) -> ShowS
escapeURIString (SystemOS -> Char -> Bool
isUnescapedInUriPath SystemOS
System.Info.os)

toNormalizedUri :: Uri -> NormalizedUri
toNormalizedUri :: Uri -> NormalizedUri
toNormalizedUri Uri
uri = Int -> Text -> NormalizedUri
NormalizedUri (Text -> Int
forall a. Hashable a => a -> Int
hash Text
norm) Text
norm
  where (Uri Text
t) = Uri -> (SystemOS -> Uri) -> Maybe SystemOS -> Uri
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Uri
uri SystemOS -> Uri
filePathToUri (Uri -> Maybe SystemOS
uriToFilePath Uri
uri)
        -- To ensure all `Uri`s have the file path normalized
        norm :: Text
norm = SystemOS -> Text
T.pack (ShowS
normalizeUriEscaping (Text -> SystemOS
T.unpack Text
t))

fromNormalizedUri :: NormalizedUri -> Uri
fromNormalizedUri :: NormalizedUri -> Uri
fromNormalizedUri (NormalizedUri Int
_ Text
t) = Text -> Uri
Uri Text
t

fileScheme :: String
fileScheme :: SystemOS
fileScheme = SystemOS
"file:"

windowsOS :: String
windowsOS :: SystemOS
windowsOS = SystemOS
"mingw32"

type SystemOS = String

uriToFilePath :: Uri -> Maybe FilePath
uriToFilePath :: Uri -> Maybe SystemOS
uriToFilePath = SystemOS -> Uri -> Maybe SystemOS
platformAwareUriToFilePath SystemOS
System.Info.os

{-# WARNING platformAwareUriToFilePath "This function is considered private. Use normalizedFilePathToUri instead." #-}
platformAwareUriToFilePath :: String -> Uri -> Maybe FilePath
platformAwareUriToFilePath :: SystemOS -> Uri -> Maybe SystemOS
platformAwareUriToFilePath SystemOS
systemOS (Uri Text
uri) = do
  URI{SystemOS
Maybe URIAuth
uriScheme :: SystemOS
uriAuthority :: Maybe URIAuth
uriPath :: SystemOS
uriQuery :: SystemOS
uriFragment :: SystemOS
uriAuthority :: URI -> Maybe URIAuth
uriFragment :: URI -> SystemOS
uriPath :: URI -> SystemOS
uriQuery :: URI -> SystemOS
uriScheme :: URI -> SystemOS
..} <- SystemOS -> Maybe URI
parseURI (SystemOS -> Maybe URI) -> SystemOS -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> SystemOS
T.unpack Text
uri
  if SystemOS
uriScheme SystemOS -> SystemOS -> Bool
forall a. Eq a => a -> a -> Bool
== SystemOS
fileScheme
    then SystemOS -> Maybe SystemOS
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (SystemOS -> Maybe SystemOS) -> SystemOS -> Maybe SystemOS
forall a b. (a -> b) -> a -> b
$
      SystemOS -> Maybe SystemOS -> ShowS
platformAdjustFromUriPath SystemOS
systemOS (URIAuth -> SystemOS
uriRegName (URIAuth -> SystemOS) -> Maybe URIAuth -> Maybe SystemOS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe URIAuth
uriAuthority) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
unEscapeString SystemOS
uriPath
    else Maybe SystemOS
forall a. Maybe a
Nothing

-- | We pull in the authority because in relative file paths the Uri likes to put everything before the slash
--   into the authority field
platformAdjustFromUriPath :: SystemOS
                          -> Maybe String -- ^ authority
                          -> String -- ^ path
                          -> FilePath
platformAdjustFromUriPath :: SystemOS -> Maybe SystemOS -> ShowS
platformAdjustFromUriPath SystemOS
systemOS Maybe SystemOS
authority SystemOS
srcPath =
  ShowS -> (SystemOS -> ShowS) -> Maybe SystemOS -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id SystemOS -> ShowS
forall a. [a] -> [a] -> [a]
(++) Maybe SystemOS
authority ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
  if SystemOS
systemOS SystemOS -> SystemOS -> Bool
forall a. Eq a => a -> a -> Bool
/= SystemOS
windowsOS
  then SystemOS
srcPath
  else case SystemOS -> [SystemOS]
FPP.splitDirectories (SystemOS -> [SystemOS]) -> Maybe SystemOS -> Maybe [SystemOS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemOS -> Maybe SystemOS
forall a. [a] -> Maybe [a]
tailMay SystemOS
srcPath of
      Just (SystemOS
firstSegment:[SystemOS]
rest) -> -- Drop leading '/' for absolute Windows paths
        let drive :: SystemOS
drive = if SystemOS -> Bool
FPW.isDrive SystemOS
firstSegment
                    then ShowS
FPW.addTrailingPathSeparator SystemOS
firstSegment
                    else SystemOS
firstSegment
         in SystemOS -> ShowS
FPW.joinDrive SystemOS
drive ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [SystemOS] -> SystemOS
FPW.joinPath [SystemOS]
rest
      Maybe [SystemOS]
_ -> SystemOS
srcPath

filePathToUri :: FilePath -> Uri
filePathToUri :: SystemOS -> Uri
filePathToUri = SystemOS -> SystemOS -> Uri
platformAwareFilePathToUri SystemOS
System.Info.os (SystemOS -> Uri) -> ShowS -> SystemOS -> Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.normalise

{-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-}
platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri
platformAwareFilePathToUri :: SystemOS -> SystemOS -> Uri
platformAwareFilePathToUri SystemOS
systemOS SystemOS
fp = Text -> Uri
Uri (Text -> Uri) -> (URI -> Text) -> URI -> Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemOS -> Text
T.pack (SystemOS -> Text) -> (URI -> SystemOS) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> SystemOS
forall a. Show a => a -> SystemOS
show (URI -> Uri) -> URI -> Uri
forall a b. (a -> b) -> a -> b
$ URI
  { uriScheme :: SystemOS
uriScheme = SystemOS
fileScheme
  , uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> a -> b
$ SystemOS -> SystemOS -> SystemOS -> URIAuth
URIAuth SystemOS
"" SystemOS
"" SystemOS
""
  , uriPath :: SystemOS
uriPath = SystemOS -> ShowS
platformAdjustToUriPath SystemOS
systemOS SystemOS
fp
  , uriQuery :: SystemOS
uriQuery = SystemOS
""
  , uriFragment :: SystemOS
uriFragment = SystemOS
""
  }

platformAdjustToUriPath :: SystemOS -> FilePath -> String
platformAdjustToUriPath :: SystemOS -> ShowS
platformAdjustToUriPath SystemOS
systemOS SystemOS
srcPath
  | SystemOS
systemOS SystemOS -> SystemOS -> Bool
forall a. Eq a => a -> a -> Bool
== SystemOS
windowsOS = Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: SystemOS
escapedPath
  | Bool
otherwise = SystemOS
escapedPath
  where
    (SystemOS -> [SystemOS]
splitDirectories, SystemOS -> (SystemOS, SystemOS)
splitDrive)
      | SystemOS
systemOS SystemOS -> SystemOS -> Bool
forall a. Eq a => a -> a -> Bool
== SystemOS
windowsOS =
          (SystemOS -> [SystemOS]
FPW.splitDirectories, SystemOS -> (SystemOS, SystemOS)
FPW.splitDrive)
      | Bool
otherwise =
          (SystemOS -> [SystemOS]
FPP.splitDirectories, SystemOS -> (SystemOS, SystemOS)
FPP.splitDrive)
    escapedPath :: SystemOS
escapedPath =
        case SystemOS -> (SystemOS, SystemOS)
splitDrive SystemOS
srcPath of
            (SystemOS
drv, SystemOS
rest) ->
                ShowS
convertDrive SystemOS
drv SystemOS -> ShowS
`FPP.joinDrive`
                [SystemOS] -> SystemOS
FPP.joinPath (ShowS -> [SystemOS] -> [SystemOS]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> ShowS
escapeURIString (SystemOS -> Char -> Bool
isUnescapedInUriPath SystemOS
systemOS)) ([SystemOS] -> [SystemOS]) -> [SystemOS] -> [SystemOS]
forall a b. (a -> b) -> a -> b
$ SystemOS -> [SystemOS]
splitDirectories SystemOS
rest)
    -- splitDirectories does not remove the path separator after the drive so
    -- we do a final replacement of \ to /
    convertDrive :: ShowS
convertDrive SystemOS
drv
      | SystemOS
systemOS SystemOS -> SystemOS -> Bool
forall a. Eq a => a -> a -> Bool
== SystemOS
windowsOS Bool -> Bool -> Bool
&& SystemOS -> Bool
FPW.hasTrailingPathSeparator SystemOS
drv =
          ShowS
FPP.addTrailingPathSeparator (ShowS
forall a. HasCallStack => [a] -> [a]
init SystemOS
drv)
      | Bool
otherwise = SystemOS
drv

{-| A file path that is already normalized.

The 'NormalizedUri' is cached to avoided
repeated normalisation when we need to compute them (which is a lot).

This is one of the most performance critical parts of HLS, do not
modify it without profiling.

== Adoption Plan of OsPath

Currently we store 'Text'. We may change it to OsPath in the future if
the following steps are executed.

1. In the client codebase, use 'osPathToNormalizedFilePath' and 'normalizedFilePathToOsPath' instead of 'fromNormalizedFilePath'
  and 'toNormalizedFilePath'. For HLS, we could wait until GHC 9.6 becomes the oldest
  GHC we support, then change 'FilePath' to OsPath everywhere in the codebase.
2. Deprecate and remove 'fromNormalizedFilePath' and 'toNormalizedFilePath'.
3. Change 'Text' to OsPath and benchmark it to make sure performance doesn't go down. Don't forget to check Windows,
  as OsPath on Windows uses UTF-16, which may consume more memory.

See [#453](https://github.com/haskell/lsp/pull/453) and [#446](https://github.com/haskell/lsp/pull/446)
for more discussions on this topic.
-}
data NormalizedFilePath = NormalizedFilePath !NormalizedUri {-# UNPACK #-} !Text
    deriving ((forall x. NormalizedFilePath -> Rep NormalizedFilePath x)
-> (forall x. Rep NormalizedFilePath x -> NormalizedFilePath)
-> Generic NormalizedFilePath
forall x. Rep NormalizedFilePath x -> NormalizedFilePath
forall x. NormalizedFilePath -> Rep NormalizedFilePath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NormalizedFilePath -> Rep NormalizedFilePath x
from :: forall x. NormalizedFilePath -> Rep NormalizedFilePath x
$cto :: forall x. Rep NormalizedFilePath x -> NormalizedFilePath
to :: forall x. Rep NormalizedFilePath x -> NormalizedFilePath
Generic, NormalizedFilePath -> NormalizedFilePath -> Bool
(NormalizedFilePath -> NormalizedFilePath -> Bool)
-> (NormalizedFilePath -> NormalizedFilePath -> Bool)
-> Eq NormalizedFilePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NormalizedFilePath -> NormalizedFilePath -> Bool
== :: NormalizedFilePath -> NormalizedFilePath -> Bool
$c/= :: NormalizedFilePath -> NormalizedFilePath -> Bool
/= :: NormalizedFilePath -> NormalizedFilePath -> Bool
Eq, Eq NormalizedFilePath
Eq NormalizedFilePath =>
(NormalizedFilePath -> NormalizedFilePath -> Ordering)
-> (NormalizedFilePath -> NormalizedFilePath -> Bool)
-> (NormalizedFilePath -> NormalizedFilePath -> Bool)
-> (NormalizedFilePath -> NormalizedFilePath -> Bool)
-> (NormalizedFilePath -> NormalizedFilePath -> Bool)
-> (NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath)
-> (NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath)
-> Ord NormalizedFilePath
NormalizedFilePath -> NormalizedFilePath -> Bool
NormalizedFilePath -> NormalizedFilePath -> Ordering
NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NormalizedFilePath -> NormalizedFilePath -> Ordering
compare :: NormalizedFilePath -> NormalizedFilePath -> Ordering
$c< :: NormalizedFilePath -> NormalizedFilePath -> Bool
< :: NormalizedFilePath -> NormalizedFilePath -> Bool
$c<= :: NormalizedFilePath -> NormalizedFilePath -> Bool
<= :: NormalizedFilePath -> NormalizedFilePath -> Bool
$c> :: NormalizedFilePath -> NormalizedFilePath -> Bool
> :: NormalizedFilePath -> NormalizedFilePath -> Bool
$c>= :: NormalizedFilePath -> NormalizedFilePath -> Bool
>= :: NormalizedFilePath -> NormalizedFilePath -> Bool
$cmax :: NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath
max :: NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath
$cmin :: NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath
min :: NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath
Ord)

instance NFData NormalizedFilePath

instance Binary NormalizedFilePath where
  put :: NormalizedFilePath -> Put
put (NormalizedFilePath NormalizedUri
_ Text
fp) = Text -> Put
forall t. Binary t => t -> Put
put Text
fp
  get :: Get NormalizedFilePath
get = do
    Text
v <- Get Text
forall t. Binary t => Get t
Data.Binary.get :: Get Text
    NormalizedFilePath -> Get NormalizedFilePath
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (NormalizedUri -> Text -> NormalizedFilePath
NormalizedFilePath (SystemOS -> NormalizedUri
internalNormalizedFilePathToUri (Text -> SystemOS
T.unpack Text
v)) Text
v)

-- | Internal helper that takes a file path that is assumed to
-- already be normalized to a URI. It is up to the caller
-- to ensure normalization.
internalNormalizedFilePathToUri :: FilePath -> NormalizedUri
internalNormalizedFilePathToUri :: SystemOS -> NormalizedUri
internalNormalizedFilePathToUri SystemOS
fp = NormalizedUri
nuri
  where
    uriPath :: SystemOS
uriPath = SystemOS -> ShowS
platformAdjustToUriPath SystemOS
System.Info.os SystemOS
fp
    nuriStr :: Text
nuriStr = SystemOS -> Text
T.pack (SystemOS -> Text) -> SystemOS -> Text
forall a b. (a -> b) -> a -> b
$ SystemOS
fileScheme SystemOS -> ShowS
forall a. Semigroup a => a -> a -> a
<> SystemOS
"//" SystemOS -> ShowS
forall a. Semigroup a => a -> a -> a
<> SystemOS
uriPath
    nuri :: NormalizedUri
nuri = Int -> Text -> NormalizedUri
NormalizedUri (Text -> Int
forall a. Hashable a => a -> Int
hash Text
nuriStr) Text
nuriStr

instance Show NormalizedFilePath where
  show :: NormalizedFilePath -> SystemOS
show (NormalizedFilePath NormalizedUri
_ Text
fp) = SystemOS
"NormalizedFilePath " SystemOS -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> SystemOS
forall a. Show a => a -> SystemOS
show Text
fp

instance Hashable NormalizedFilePath where
  hash :: NormalizedFilePath -> Int
hash (NormalizedFilePath NormalizedUri
uri Text
_) = NormalizedUri -> Int
forall a. Hashable a => a -> Int
hash NormalizedUri
uri
  hashWithSalt :: Int -> NormalizedFilePath -> Int
hashWithSalt Int
salt (NormalizedFilePath NormalizedUri
uri Text
_) = Int -> NormalizedUri -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt NormalizedUri
uri

instance IsString NormalizedFilePath where
    fromString :: String -> NormalizedFilePath
    fromString :: SystemOS -> NormalizedFilePath
fromString = SystemOS -> NormalizedFilePath
toNormalizedFilePath

toNormalizedFilePath :: FilePath -> NormalizedFilePath
toNormalizedFilePath :: SystemOS -> NormalizedFilePath
toNormalizedFilePath SystemOS
fp = NormalizedUri -> Text -> NormalizedFilePath
NormalizedFilePath NormalizedUri
nuri (Text -> NormalizedFilePath)
-> (SystemOS -> Text) -> SystemOS -> NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemOS -> Text
T.pack (SystemOS -> NormalizedFilePath) -> SystemOS -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ SystemOS
nfp
  where
    nfp :: SystemOS
nfp = ShowS
FP.normalise SystemOS
fp
    nuri :: NormalizedUri
nuri = SystemOS -> NormalizedUri
internalNormalizedFilePathToUri SystemOS
nfp

-- | Extracts 'FilePath' from 'NormalizedFilePath'.
fromNormalizedFilePath :: NormalizedFilePath -> FilePath
fromNormalizedFilePath :: NormalizedFilePath -> SystemOS
fromNormalizedFilePath (NormalizedFilePath NormalizedUri
_ Text
fp) = Text -> SystemOS
T.unpack Text
fp

normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri
normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri
normalizedFilePathToUri (NormalizedFilePath NormalizedUri
uri Text
_) = NormalizedUri
uri

uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath NormalizedUri
nuri = (SystemOS -> NormalizedFilePath)
-> Maybe SystemOS -> Maybe NormalizedFilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NormalizedUri -> Text -> NormalizedFilePath
NormalizedFilePath NormalizedUri
nuri (Text -> NormalizedFilePath)
-> (SystemOS -> Text) -> SystemOS -> NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemOS -> Text
T.pack) Maybe SystemOS
mbFilePath
  where mbFilePath :: Maybe SystemOS
mbFilePath = SystemOS -> Uri -> Maybe SystemOS
platformAwareUriToFilePath SystemOS
System.Info.os (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
nuri)

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

-- | 'NormalizedFilePath' that contains an empty file path
emptyNormalizedFilePath :: NormalizedFilePath
emptyNormalizedFilePath :: NormalizedFilePath
emptyNormalizedFilePath = NormalizedUri -> Text -> NormalizedFilePath
NormalizedFilePath NormalizedUri
emptyNormalizedUri Text
""