|
| 1 | +{-# LANGUAGE DerivingStrategies #-} |
| 2 | +{-# LANGUAGE PatternSynonyms #-} |
| 3 | +{-# LANGUAGE ViewPatterns #-} |
| 4 | + |
| 5 | +module Development.IDE.Graph.Internal.Key |
| 6 | + ( Key -- Opaque - don't expose constructor, use newKey to create |
| 7 | + , KeyValue (..) |
| 8 | + , pattern Key |
| 9 | + , newKey |
| 10 | + , renderKey |
| 11 | + -- * KeyMap |
| 12 | + , KeyMap |
| 13 | + , mapKeyMap |
| 14 | + , insertKeyMap |
| 15 | + , lookupKeyMap |
| 16 | + , lookupDefaultKeyMap |
| 17 | + , fromListKeyMap |
| 18 | + , fromListWithKeyMap |
| 19 | + , toListKeyMap |
| 20 | + , elemsKeyMap |
| 21 | + , restrictKeysKeyMap |
| 22 | + -- * KeySet |
| 23 | + , KeySet |
| 24 | + , nullKeySet |
| 25 | + , insertKeySet |
| 26 | + , memberKeySet |
| 27 | + , toListKeySet |
| 28 | + , lengthKeySet |
| 29 | + , filterKeySet |
| 30 | + , singletonKeySet |
| 31 | + , fromListKeySet |
| 32 | + , deleteKeySet |
| 33 | + , differenceKeySet |
| 34 | + ) where |
| 35 | + |
| 36 | +--import Control.Monad.IO.Class () |
| 37 | +import Data.Coerce |
| 38 | +import Data.Dynamic |
| 39 | +import qualified Data.HashMap.Strict as Map |
| 40 | +import Data.IntMap (IntMap) |
| 41 | +import qualified Data.IntMap.Strict as IM |
| 42 | +import Data.IntSet (IntSet) |
| 43 | +import qualified Data.IntSet as IS |
| 44 | +import Data.IORef |
| 45 | +import Data.Text (Text) |
| 46 | +import qualified Data.Text as T |
| 47 | +import Data.Typeable |
| 48 | +import Development.IDE.Graph.Classes |
| 49 | +import System.IO.Unsafe |
| 50 | + |
| 51 | + |
| 52 | +newtype Key = UnsafeMkKey Int |
| 53 | + |
| 54 | +pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key |
| 55 | +pattern Key a <- (lookupKeyValue -> KeyValue a _) |
| 56 | +{-# COMPLETE Key #-} |
| 57 | + |
| 58 | +data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text |
| 59 | + |
| 60 | +instance Eq KeyValue where |
| 61 | + KeyValue a _ == KeyValue b _ = Just a == cast b |
| 62 | +instance Hashable KeyValue where |
| 63 | + hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x) |
| 64 | +instance Show KeyValue where |
| 65 | + show (KeyValue _ t) = T.unpack t |
| 66 | + |
| 67 | +data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int |
| 68 | + |
| 69 | +keyMap :: IORef GlobalKeyValueMap |
| 70 | +keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0) |
| 71 | + |
| 72 | +{-# NOINLINE keyMap #-} |
| 73 | + |
| 74 | +newKey :: (Typeable a, Hashable a, Show a) => a -> Key |
| 75 | +newKey k = unsafePerformIO $ do |
| 76 | + let !newKey = KeyValue k (T.pack (show k)) |
| 77 | + atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) -> |
| 78 | + let new_key = Map.lookup newKey hm |
| 79 | + in case new_key of |
| 80 | + Just v -> (km, v) |
| 81 | + Nothing -> |
| 82 | + let !new_index = UnsafeMkKey n |
| 83 | + in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) |
| 84 | +{-# NOINLINE newKey #-} |
| 85 | + |
| 86 | +lookupKeyValue :: Key -> KeyValue |
| 87 | +lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do |
| 88 | + GlobalKeyValueMap _ im _ <- readIORef keyMap |
| 89 | + pure $! im IM.! x |
| 90 | + |
| 91 | +{-# NOINLINE lookupKeyValue #-} |
| 92 | + |
| 93 | +instance Eq Key where |
| 94 | + UnsafeMkKey a == UnsafeMkKey b = a == b |
| 95 | +instance Hashable Key where |
| 96 | + hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x |
| 97 | +instance Show Key where |
| 98 | + show (Key x) = show x |
| 99 | + |
| 100 | +renderKey :: Key -> Text |
| 101 | +renderKey (lookupKeyValue -> KeyValue _ t) = t |
| 102 | + |
| 103 | +newtype KeySet = KeySet IntSet |
| 104 | + deriving newtype (Eq, Ord, Semigroup, Monoid) |
| 105 | + |
| 106 | +instance Show KeySet where |
| 107 | + showsPrec p (KeySet is)= showParen (p > 10) $ |
| 108 | + showString "fromList " . shows ks |
| 109 | + where ks = coerce (IS.toList is) :: [Key] |
| 110 | + |
| 111 | +insertKeySet :: Key -> KeySet -> KeySet |
| 112 | +insertKeySet = coerce IS.insert |
| 113 | + |
| 114 | +memberKeySet :: Key -> KeySet -> Bool |
| 115 | +memberKeySet = coerce IS.member |
| 116 | + |
| 117 | +toListKeySet :: KeySet -> [Key] |
| 118 | +toListKeySet = coerce IS.toList |
| 119 | + |
| 120 | +nullKeySet :: KeySet -> Bool |
| 121 | +nullKeySet = coerce IS.null |
| 122 | + |
| 123 | +differenceKeySet :: KeySet -> KeySet -> KeySet |
| 124 | +differenceKeySet = coerce IS.difference |
| 125 | + |
| 126 | +deleteKeySet :: Key -> KeySet -> KeySet |
| 127 | +deleteKeySet = coerce IS.delete |
| 128 | + |
| 129 | +fromListKeySet :: [Key] -> KeySet |
| 130 | +fromListKeySet = coerce IS.fromList |
| 131 | + |
| 132 | +singletonKeySet :: Key -> KeySet |
| 133 | +singletonKeySet = coerce IS.singleton |
| 134 | + |
| 135 | +filterKeySet :: (Key -> Bool) -> KeySet -> KeySet |
| 136 | +filterKeySet = coerce IS.filter |
| 137 | + |
| 138 | +lengthKeySet :: KeySet -> Int |
| 139 | +lengthKeySet = coerce IS.size |
| 140 | + |
| 141 | +newtype KeyMap a = KeyMap (IntMap a) |
| 142 | + deriving newtype (Eq, Ord, Semigroup, Monoid) |
| 143 | + |
| 144 | +instance Show a => Show (KeyMap a) where |
| 145 | + showsPrec p (KeyMap im)= showParen (p > 10) $ |
| 146 | + showString "fromList " . shows ks |
| 147 | + where ks = coerce (IM.toList im) :: [(Key,a)] |
| 148 | + |
| 149 | +mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b |
| 150 | +mapKeyMap f (KeyMap m) = KeyMap (IM.map f m) |
| 151 | + |
| 152 | +insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a |
| 153 | +insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m) |
| 154 | + |
| 155 | +lookupKeyMap :: Key -> KeyMap a -> Maybe a |
| 156 | +lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m |
| 157 | + |
| 158 | +lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a |
| 159 | +lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m |
| 160 | + |
| 161 | +fromListKeyMap :: [(Key,a)] -> KeyMap a |
| 162 | +fromListKeyMap xs = KeyMap (IM.fromList (coerce xs)) |
| 163 | + |
| 164 | +fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a |
| 165 | +fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs)) |
| 166 | + |
| 167 | +toListKeyMap :: KeyMap a -> [(Key,a)] |
| 168 | +toListKeyMap (KeyMap m) = coerce (IM.toList m) |
| 169 | + |
| 170 | +elemsKeyMap :: KeyMap a -> [a] |
| 171 | +elemsKeyMap (KeyMap m) = IM.elems m |
| 172 | + |
| 173 | +restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a |
| 174 | +restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) |
0 commit comments