diff options
Diffstat (limited to 'source/Report')
| -rw-r--r-- | source/Report/Location.hs | 284 |
1 files changed, 0 insertions, 284 deletions
diff --git a/source/Report/Location.hs b/source/Report/Location.hs deleted file mode 100644 index 4495360..0000000 --- a/source/Report/Location.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} - -module 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 |