diff options
Diffstat (limited to 'source/Felix/Report/Location.hs')
| -rw-r--r-- | source/Felix/Report/Location.hs | 284 |
1 files changed, 284 insertions, 0 deletions
diff --git a/source/Felix/Report/Location.hs b/source/Felix/Report/Location.hs new file mode 100644 index 0000000..36b8997 --- /dev/null +++ b/source/Felix/Report/Location.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +module Felix.Report.Location where + +import Base +import Text.Megaparsec.Pos (SourcePos (sourceColumn, sourceLine), unPos) +import Data.Bits +import Control.DeepSeq (NFData) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.IntMap.Strict qualified as IntMap +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Word (Word16, Word32) +import System.IO.Unsafe (unsafePerformIO) + +-- | File identifier used in packed source locations. +newtype FileId = FileId + { unFileId :: Word16 + } deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + +-- | Packed source location. +-- Bit layout (high to low): +-- 16 bits file id | 24 bits line | 24 bits column. +newtype Location = Location + { unLocation :: Word64 + } deriving stock (Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) + +data RegisteredFile = RegisteredFile + { registeredFileIdentity :: FilePath + , registeredFileDisplayPath :: FilePath + } + +data FileRegistry = FileRegistry + { registrationToFileId :: Map (FilePath, FilePath) FileId + , fileIdToFile :: IntMap RegisteredFile + , fileIdAllocator :: !FileIdAllocator + } + +data LocationRegistrationError + = FileIdSpaceExhausted + deriving stock (Show, Eq) + +data LocationConstructionError + = LocationCoordinateOutOfRange !Int !Int + deriving stock (Show, Eq) + +newtype FileIdAllocator = FileIdAllocator Word32 + deriving stock (Show, Eq) + +initialFileIdAllocator :: FileIdAllocator +initialFileIdAllocator = FileIdAllocator 0 + +allocateFileId + :: FileIdAllocator + -> Either LocationRegistrationError (FileId, FileIdAllocator) +allocateFileId (FileIdAllocator next) + | next >= fromIntegral (maxBound :: Word16) = + Left FileIdSpaceExhausted + | otherwise = + Right + ( FileId (fromIntegral next) + , FileIdAllocator (next + 1) + ) + +initialFileRegistry :: FileRegistry +initialFileRegistry = FileRegistry + { registrationToFileId = mempty + , fileIdToFile = mempty + , fileIdAllocator = initialFileIdAllocator + } + +fileRegistryRef :: IORef FileRegistry +fileRegistryRef = unsafePerformIO (newIORef initialFileRegistry) +{-# NOINLINE fileRegistryRef #-} + +registerFilePath + :: MonadIO io + => FilePath + -> io (Either LocationRegistrationError FileId) +registerFilePath path = + registerFilePathWithDisplay path path + +-- | Register a file by physical identity while retaining a separate path for +-- diagnostics. The identity must be stable and unique for the selected +-- physical source. Distinct display paths receive distinct file identifiers so +-- one workspace cannot inherit another workspace's presentation. Callers with +-- only one path should use 'registerFilePath'. +registerFilePathWithDisplay + :: MonadIO io + => FilePath + -> FilePath + -> io (Either LocationRegistrationError FileId) +registerFilePathWithDisplay identity displayPath = liftIO $ + atomicModifyIORef' fileRegistryRef \registry -> + case Map.lookup registration (registrationToFileId registry) of + Just fileId -> + (registry, Right fileId) + Nothing -> + case allocateFileId (fileIdAllocator registry) of + Left err -> + (registry, Left err) + Right (fileId, nextAllocator) -> + let fileIdInt = fromIntegral (unFileId fileId) + registeredFile = + RegisteredFile identity displayPath + registry' = FileRegistry + { registrationToFileId = + Map.insert + registration + fileId + (registrationToFileId registry) + , fileIdToFile = + IntMap.insert + fileIdInt + registeredFile + (fileIdToFile registry) + , fileIdAllocator = nextAllocator + } + in + (registry', Right fileId) + where + registration = (identity, displayPath) + +lookupFilePath :: FileId -> Maybe FilePath +lookupFilePath fileId = unsafePerformIO do + registry <- readIORef fileRegistryRef + pure + (registeredFileDisplayPath <$> + IntMap.lookup + (fromIntegral (unFileId fileId)) + (fileIdToFile registry)) + +lookupFileIdentityPath :: FileId -> Maybe FilePath +lookupFileIdentityPath fileId = unsafePerformIO do + registry <- readIORef fileRegistryRef + pure + (registeredFileIdentity <$> + IntMap.lookup + (fromIntegral (unFileId fileId)) + (fileIdToFile registry)) + +fileShift, lineShift :: Int +fileShift = 48 +lineShift = 24 + +fileMask, coordMask :: Word64 +fileMask = 0xFFFF +coordMask = 0xFFFFFF + +nowhereWord :: Word64 +nowhereWord = maxBound + +mkLocationChecked + :: FileId + -> Int + -> Int + -> Either LocationConstructionError Location +mkLocationChecked fileId line column + | line < 0 + || column < 0 + || lineWord > coordMask + || columnWord > coordMask = + Left (LocationCoordinateOutOfRange line column) + | otherwise = + Right + (Location + ( (fromIntegral (unFileId fileId) `shiftL` fileShift) + .|. (lineWord `shiftL` lineShift) + .|. columnWord + )) + where + lineWord = fromIntegral line :: Word64 + columnWord = fromIntegral column :: Word64 + +mkLocation :: FileId -> Int -> Int -> Location +mkLocation fileId line column = + either + (impossible . ("mkLocation: " <>) . show) + id + (mkLocationChecked fileId line column) + +locFileId :: Location -> Maybe FileId +locFileId (Location w) + | w == nowhereWord = Nothing + | otherwise = Just (FileId (fromIntegral ((w `shiftR` fileShift) .&. fileMask))) + +locFile :: Location -> FilePath +locFile loc = case locFileId loc of + Nothing -> "<nowhere>" + Just fileId -> + fromMaybe ("<file#" <> show (unFileId fileId) <> ">") (lookupFilePath fileId) + +locLine :: Location -> Int +locLine (Location w) + | w == nowhereWord = -1 + | otherwise = fromIntegral ((w `shiftR` lineShift) .&. coordMask) + +locColumn :: Location -> Int +locColumn (Location w) + | w == nowhereWord = -1 + | otherwise = fromIntegral (w .&. coordMask) + +instance Show Location where + showsPrec p loc = + showParen (p > appPrec) $ + showString "Location {locFile = " + . shows (locFile loc) + . showString ", locLine = " + . shows (locLine loc) + . showString ", locColumn = " + . shows (locColumn loc) + . showString "}" + where + appPrec = 10 + +fromSourcePosChecked + :: FileId + -> SourcePos + -> Either LocationConstructionError Location +fromSourcePosChecked fileId pos = + mkLocationChecked + fileId + (unPos (sourceLine pos)) + (unPos (sourceColumn pos)) + +prettyLocation :: Location -> String +prettyLocation loc = + locFile loc <> " " <> show (locLine loc) <> ":" <> show (locColumn loc) + +-- | Render two locations together, qualifying equal display paths when they +-- refer to different physical files. +prettyLocationPair :: Location -> Location -> (String, String) +prettyLocationPair firstLocation secondLocation = + if locFile firstLocation == locFile secondLocation + && firstIdentity /= secondIdentity + && isJust firstIdentity + && isJust secondIdentity + then + ( qualify firstIdentity firstLocation + , qualify secondIdentity secondLocation + ) + else + (prettyLocation firstLocation, prettyLocation secondLocation) + where + firstIdentity = + locFileId firstLocation >>= lookupFileIdentityPath + secondIdentity = + locFileId secondLocation >>= lookupFileIdentityPath + + qualify identity location = + locFile location + <> " (canonical " + <> maybe "<unknown>" show identity + <> ") " + <> show (locLine location) + <> ":" + <> show (locColumn location) + +locationToText :: Location -> Text +locationToText loc = Text.pack (prettyLocation loc) + +-- | Things that have a location. +class Locatable a where + locate :: a -> Location + +pattern Nowhere :: Location +pattern Nowhere = Location 0xFFFFFFFFFFFFFFFF + +instance Locatable Location where + locate = id + +instance Locatable a => Locatable [a] where + locate [] = Nowhere + locate (x:_) = locate x + +instance Locatable a => Locatable (Maybe a) where + locate Nothing = Nowhere + locate (Just x) = locate x + +instance Locatable a => Locatable (NonEmpty a) where + locate (x :| _) = locate x |