Hashcons NormalizedFilePath values for efficient heap usage

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -8,7 +9,7 @@ module Language.LSP.Types.Uri
   , NormalizedUri(..)
   , toNormalizedUri
   , fromNormalizedUri
-  , NormalizedFilePath(..)
+  , NormalizedFilePath
   , toNormalizedFilePath
   , fromNormalizedFilePath
   , normalizedFilePathToUri
@@ -23,16 +24,20 @@ import           Control.DeepSeq
 import qualified Data.Aeson                                 as A
 import           Data.Binary                                (Binary, Get, put, get)
 import           Data.Hashable
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef                                (atomicModifyIORef', newIORef)
 import           Data.List                                  (stripPrefix)
 import           Data.String                                (IsString, fromString)
 import           Data.Text                                  (Text)
 import qualified Data.Text                                  as T
+import           Data.Tuple                                (swap)
 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 qualified System.Info
+import           System.IO.Unsafe                          (unsafePerformIO)
 
 newtype Uri = Uri { getUri :: Text }
   deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey)
@@ -165,7 +170,11 @@ instance Binary NormalizedFilePath where
   get = do
     v <- Data.Binary.get :: Get FilePath
     let nuri = internalNormalizedFilePathToUri v
-    return (NormalizedFilePath nuri v)
+    return (normalizedFilePath nuri v)
+
+-- | A smart constructor that performs UTF-8 encoding and hash consing
+normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath
+normalizedFilePath nuri nfp = intern $ NormalizedFilePath nuri nfp
 
 -- | Internal helper that takes a file path that is assumed to
 -- already be normalized to a URI. It is up to the caller
@@ -188,7 +197,7 @@ instance IsString NormalizedFilePath where
     fromString = toNormalizedFilePath
 
 toNormalizedFilePath :: FilePath -> NormalizedFilePath
-toNormalizedFilePath fp = NormalizedFilePath nuri nfp
+toNormalizedFilePath fp = normalizedFilePath nuri nfp
   where
       nfp = FP.normalise fp
       nuri = internalNormalizedFilePathToUri nfp
@@ -200,5 +209,20 @@ normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri
 normalizedFilePathToUri (NormalizedFilePath uri _) = uri
 
 uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath
-uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri) mbFilePath
+uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath
   where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri)
+
+---------------------------------------------------------------------------
+-- Unsafe hashcons of NFP
+internIO :: (Eq a, Hashable a) => IO (a -> IO a)
+internIO = do
+    tableRef <- newIORef mempty
+    let f x = atomicModifyIORef' tableRef $ swap . flip HM.alterF x (\case
+         Just res -> (res, Just res)
+         Nothing  -> (x, Just x)
+         )
+    return f
+
+{-# NOINLINE intern #-}
+intern :: NormalizedFilePath -> NormalizedFilePath
+intern = let f = unsafePerformIO internIO in \x -> unsafePerformIO (f x)