use OsPath in NormalizedFilePath

.github/workflows/haskell.yml

@@ -9,8 +9,13 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ['9.2.1', '9.0.1', '8.10.7', '8.8.4', '8.6.5']
+        ghc: ['9.2.4', '9.0.2', '8.10.7', '8.8.4', '8.6.5']
         os: [ubuntu-latest, macOS-latest, windows-latest]
+        ospath: [true, false]
+        exclude:
+        # newer 'entropy' doesn't work with old 'unix', and it doesn't have a correct version bound.
+          - ospath: true
+            ghc: 8.6.5
 
     steps:
     - uses: actions/checkout@v2
@@ -41,6 +46,12 @@ jobs:
 
     - name: Cabal update
       run: cabal update
+    - name: Cabal configure
+      shell: bash
+      run: |
+        if [ ${{ matrix.ospath }} = "true" ]; then
+          cabal configure --constraint="filepath ^>= 1.4.100.0"
+        fi
     - name: Build using cabal
       run: cabal build all
     - name: Test

lsp-types/lsp-types.cabal

@@ -89,6 +89,9 @@ library
                      , text
                      , template-haskell
                      , unordered-containers
+                     , exceptions
+                     , safe
+                     , bytestring
   hs-source-dirs:      src
   default-language:    Haskell2010
   default-extensions: StrictData
@@ -106,6 +109,7 @@ test-suite lsp-types-test
                        TypesSpec
                        URIFilePathSpec
                        WorkspaceEditSpec
+                       LocationSpec
   build-depends:       base
                      , QuickCheck
                      -- for instance Arbitrary Value
@@ -117,6 +121,7 @@ test-suite lsp-types-test
                      , network-uri
                      , quickcheck-instances
                      , text
+                     , tuple
   build-tool-depends:  hspec-discover:hspec-discover
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   default-language:    Haskell2010

lsp-types/src/Language/LSP/Types/Uri.hs

@@ -1,7 +1,13 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+
+#if MIN_VERSION_filepath(1,4,100)
+#define OS_PATH 1
+#endif
+
 module Language.LSP.Types.Uri
   ( Uri(..)
   , uriToFilePath
@@ -10,32 +16,57 @@ module Language.LSP.Types.Uri
   , toNormalizedUri
   , fromNormalizedUri
   , NormalizedFilePath
-  , normalizedFilePath
   , toNormalizedFilePath
   , fromNormalizedFilePath
   , normalizedFilePathToUri
   , uriToNormalizedFilePath
+  , filePathToNormalizedFilePath
+  , normalizedFilePathToFilePath
   -- Private functions
   , platformAwareUriToFilePath
   , platformAwareFilePathToUri
   )
   where
 
 import           Control.DeepSeq
-import qualified Data.Aeson                                 as A
-import           Data.Binary                                (Binary, Get, put, get)
+import           Control.Monad.Catch            (MonadThrow)
+import qualified Data.Aeson                     as A
+import           Data.Binary                    (Binary, Get, get, put)
+import           Data.ByteString.Short          (ShortByteString)
 import           Data.Hashable
-import           Data.List                                  (stripPrefix)
-import           Data.String                                (IsString, fromString)
-import           Data.Text                                  (Text)
-import qualified Data.Text                                  as T
+import           Data.List                      (stripPrefix)
+import           Data.Maybe                     (fromJust)
+import           Data.Text                      (Text)
+import qualified Data.Text                      as T
 import           GHC.Generics
-import           Network.URI hiding (authority)
-import qualified System.FilePath                            as FP
-import qualified System.FilePath.Posix                      as FPP
-import qualified System.FilePath.Windows                    as FPW
+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
 
+#ifndef OS_PATH
+import qualified Data.Text.Encoding             as T
+#endif
+
+#ifdef OS_PATH
+import qualified System.OsPath                  as OsPath
+
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+import           System.OsString.Internal.Types (OsString (..),
+                                                 WindowsString (..))
+#else
+import           System.OsString.Internal.Types (OsString (..),
+                                                 PosixString (..))
+#endif
+
+#else
+import qualified Data.ByteString.Short          as BS
+import qualified System.FilePath                as OsPath
+#endif
+
+
 newtype Uri = Uri { getUri :: Text }
   deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey)
 
@@ -67,7 +98,7 @@ isUnescapedInUriPath systemOS c
 normalizeUriEscaping :: String -> String
 normalizeUriEscaping uri =
   case stripPrefix (fileScheme ++ "//") uri of
-    Just p -> fileScheme ++ "//" ++ (escapeURIPath $ unEscapeString p)
+    Just p  -> fileScheme ++ "//" ++ escapeURIPath (unEscapeString p)
     Nothing -> escapeURIString isUnescapedInURI $ unEscapeString uri
   where escapeURIPath = escapeURIString (isUnescapedInUriPath System.Info.os)
 
@@ -107,17 +138,19 @@ platformAdjustFromUriPath :: SystemOS
                           -> String -- ^ path
                           -> FilePath
 platformAdjustFromUriPath systemOS authority srcPath =
-  (maybe id (++) authority) $
-  if systemOS /= windowsOS || null srcPath then srcPath
-    else let
-      firstSegment:rest = (FPP.splitDirectories . tail) srcPath  -- Drop leading '/' for absolute Windows paths
-      drive = if FPW.isDrive firstSegment
-              then FPW.addTrailingPathSeparator firstSegment
-              else firstSegment
-      in FPW.joinDrive drive $ FPW.joinPath rest
+  maybe id (++) authority $
+  if systemOS /= windowsOS
+  then srcPath
+  else case FPP.splitDirectories <$> tailMay srcPath of
+      Just (firstSegment:rest) -> -- Drop leading '/' for absolute Windows paths
+        let drive = if FPW.isDrive firstSegment
+                    then FPW.addTrailingPathSeparator firstSegment
+                    else firstSegment
+         in FPW.joinDrive drive $ FPW.joinPath rest
+      _ -> srcPath
 
 filePathToUri :: FilePath -> Uri
-filePathToUri = (platformAwareFilePathToUri System.Info.os) . FP.normalise
+filePathToUri = platformAwareFilePathToUri System.Info.os . FP.normalise
 
 {-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-}
 platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri
@@ -151,37 +184,75 @@ platformAdjustToUriPath systemOS srcPath
           FPP.addTrailingPathSeparator (init drv)
       | otherwise = drv
 
+#ifdef OS_PATH
+type OsPath = OsPath.OsPath
+#else
+type OsPath = FilePath
+#endif
+
 -- | Newtype wrapper around FilePath that always has normalized slashes.
 -- The NormalizedUri and hash of the FilePath are 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 ghcide, do not
 -- modify it without profiling.
-data NormalizedFilePath = NormalizedFilePath NormalizedUri !FilePath
+data NormalizedFilePath = NormalizedFilePath !NormalizedUri {-# UNPACK #-} !ShortByteString
     deriving (Generic, Eq, Ord)
 
 instance NFData NormalizedFilePath
 
 instance Binary NormalizedFilePath where
   put (NormalizedFilePath _ fp) = put fp
   get = do
-    v <- Data.Binary.get :: Get FilePath
-    let nuri = internalNormalizedFilePathToUri v
-    return (normalizedFilePath nuri v)
-
--- | A smart constructor that performs UTF-8 encoding and hash consing
-normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath
-normalizedFilePath nuri nfp = NormalizedFilePath nuri nfp
+    v <- Data.Binary.get :: Get ShortByteString
+    let nuri = internalNormalizedFilePathToUri (wrapOsPath v)
+    return (NormalizedFilePath (fromJust nuri) v)
+
+unwrapOsPath :: OsPath -> ShortByteString
+#ifdef OS_PATH
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+unwrapOsPath = getWindowsString . getOsString
+#else
+unwrapOsPath = getPosixString . getOsString
+#endif
+#else
+unwrapOsPath = BS.toShort . T.encodeUtf8 . T.pack
+#endif
+
+wrapOsPath :: ShortByteString -> OsPath
+#ifdef OS_PATH
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+wrapOsPath = OsString . WindowsString
+#else
+wrapOsPath = OsString . PosixString
+#endif
+#else
+wrapOsPath = T.unpack . T.decodeUtf8 . BS.fromShort
+#endif
+
+decodeUtf :: MonadThrow m => OsPath -> m FilePath
+#ifdef OS_PATH
+decodeUtf = OsPath.decodeUtf
+#else
+decodeUtf = pure
+#endif
+
+encodeUtf :: MonadThrow m => FilePath -> m OsPath
+#ifdef OS_PATH
+encodeUtf = OsPath.encodeUtf
+#else
+encodeUtf = pure
+#endif
 
 -- | 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 :: MonadThrow m => OsPath -> m NormalizedUri
 internalNormalizedFilePathToUri fp = nuri
   where
-    uriPath = platformAdjustToUriPath System.Info.os fp
-    nuriStr = T.pack $ fileScheme <> "//" <> uriPath
-    nuri = NormalizedUri (hash nuriStr) nuriStr
+    uriPath = platformAdjustToUriPath System.Info.os <$> decodeUtf fp
+    nuriStr = fmap (T.pack . \p -> fileScheme <> "//" <> p) uriPath
+    nuri = fmap (\nuriStr' -> NormalizedUri (hash nuriStr') nuriStr') nuriStr
 
 instance Show NormalizedFilePath where
   show (NormalizedFilePath _ fp) = "NormalizedFilePath " ++ show fp
@@ -190,21 +261,24 @@ instance Hashable NormalizedFilePath where
   hash (NormalizedFilePath uri _) = hash uri
   hashWithSalt salt (NormalizedFilePath uri _) = hashWithSalt salt uri
 
-instance IsString NormalizedFilePath where
-    fromString = toNormalizedFilePath
+filePathToNormalizedFilePath :: MonadThrow m => FilePath -> m NormalizedFilePath
+filePathToNormalizedFilePath fp = encodeUtf fp >>= toNormalizedFilePath
+
+normalizedFilePathToFilePath :: MonadThrow m => NormalizedFilePath -> m FilePath
+normalizedFilePathToFilePath nfp = decodeUtf $ fromNormalizedFilePath nfp
 
-toNormalizedFilePath :: FilePath -> NormalizedFilePath
-toNormalizedFilePath fp = normalizedFilePath nuri nfp
+toNormalizedFilePath :: MonadThrow m => OsPath -> m NormalizedFilePath
+toNormalizedFilePath fp = flip NormalizedFilePath (unwrapOsPath nfp) <$> nuri
   where
-      nfp = FP.normalise fp
-      nuri = internalNormalizedFilePathToUri nfp
+    nfp = OsPath.normalise fp
+    nuri = internalNormalizedFilePathToUri nfp
 
-fromNormalizedFilePath :: NormalizedFilePath -> FilePath
-fromNormalizedFilePath (NormalizedFilePath _ fp) = fp
+fromNormalizedFilePath :: NormalizedFilePath -> OsPath
+fromNormalizedFilePath (NormalizedFilePath _ fp) = wrapOsPath fp
 
 normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri
 normalizedFilePathToUri (NormalizedFilePath uri _) = uri
 
 uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath
-uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath
+uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri . unwrapOsPath) (mbFilePath >>= encodeUtf)
   where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri)

lsp-types/test/URIFilePathSpec.hs

@@ -1,17 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module URIFilePathSpec where
 
-import Control.Monad                          (when)
-import Data.List
-import Data.Text                              (Text, pack)
-import Language.LSP.Types
+import           Control.Monad           (when)
+import           Data.List
+import           Data.Text               (Text, pack)
+import           Language.LSP.Types
 
-import Network.URI
-import Test.Hspec
-import Test.QuickCheck
+import           Network.URI
+import           System.FilePath         (normalise)
 import qualified System.FilePath.Windows as FPW
-import System.FilePath                        (normalise)
 import qualified System.Info
+import           Test.Hspec
+import           Test.QuickCheck
+import Data.Tuple.Curry (uncurryN)
 -- ---------------------------------------------------------------------
 
 isWindows :: Bool
@@ -185,9 +187,9 @@ uriFilePathSpec = do
 
   it "converts a file path with initial current dir to a URI and back" $ do
     let uri = filePathToUri withInitialCurrentDirFilePath
-    uri `shouldBe` (Uri (pack withInitialCurrentDirUriStr))
-    let Just (URI scheme' auth' path' query' frag') =  parseURI withInitialCurrentDirUriStr
-    (scheme',auth',path',query',frag') `shouldBe` withInitialCurrentDirUriParts
+    uri `shouldBe` Uri (pack withInitialCurrentDirUriStr)
+    let uriMaybe =  parseURI withInitialCurrentDirUriStr
+    uriMaybe `shouldBe` Just (uncurryN URI withInitialCurrentDirUriParts)
     Just "Functional.hs" `shouldBe` uriToFilePath uri
 
 uriNormalizeSpec :: Spec
@@ -224,7 +226,7 @@ uriNormalizeSpec = do
     let nuri = toNormalizedUri (filePathToUri fp)
     case uriToFilePath (fromNormalizedUri nuri) of
       Just nfp -> nfp `shouldBe` (normalise fp)
-      Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now
+      Nothing  -> return () -- Some unicode paths creates invalid uris, ignoring for now
 
 genFilePath :: Gen FilePath
 genFilePath | isWindows = genWindowsFilePath
@@ -251,28 +253,28 @@ genValidUnicodeChar = arbitraryUnicodeChar `suchThat` isCharacter
 normalizedFilePathSpec :: Spec
 normalizedFilePathSpec = do
   it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do
-    let nfp = toNormalizedFilePath fp
-    fromNormalizedFilePath nfp `shouldBe` (normalise fp)
+    let nfp = filePathToNormalizedFilePath fp
+    (normalizedFilePathToFilePath =<< nfp) `shouldBe` Just (normalise fp)
 
   it "converts to a normalized uri and back" $ property $ forAll genFilePath $ \fp -> do
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
-    case uriToNormalizedFilePath nuri of
-      Just nfp -> fromNormalizedFilePath nfp `shouldBe` (normalise fp)
-      Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now
+    let nuri = normalizedFilePathToUri <$> filePathToNormalizedFilePath fp
+    case uriToNormalizedFilePath =<< nuri of
+      Just nfp -> normalizedFilePathToFilePath nfp `shouldBe` Just (normalise fp)
+      Nothing  -> return () -- Some unicode paths creates invalid uris, ignoring for now
 
   it "converts a file path with reserved uri chars to a normalized URI and back" $ do
     let start = if isWindows then "C:\\" else "/"
     let fp = start ++ "path;part#fragmen?param=val"
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
-    fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp
+    let nuri :: Maybe NormalizedUri = normalizedFilePathToUri <$> filePathToNormalizedFilePath fp
+    (normalizedFilePathToFilePath =<< (uriToNormalizedFilePath =<< nuri)) `shouldBe` Just fp
 
   it "converts a file path with substrings that looks like uri escaped chars and back" $ do
     let start = if isWindows then "C:\\" else "/"
     let fp = start ++ "ca%C3%B1a"
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
-    fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp
+    let nuri = normalizedFilePathToUri <$> filePathToNormalizedFilePath fp
+    (normalizedFilePathToFilePath =<< (uriToNormalizedFilePath =<< nuri)) `shouldBe` Just fp
 
   it "creates the same NormalizedUri than the older implementation" $ property $ forAll genFilePath $ \fp -> do
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
+    let nuri = normalizedFilePathToUri <$> filePathToNormalizedFilePath fp
     let oldNuri = toNormalizedUri (filePathToUri fp)
-    nuri `shouldBe` oldNuri
+    nuri `shouldBe` Just oldNuri