{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module General.Intern(
    Intern, Id(..),
    empty, insert, add, lookup, toList, fromList
    ) where

import Development.Shake.Classes
import Foreign.Storable
import Data.Word
import Prelude hiding (lookup)
import qualified Data.HashMap.Strict as Map
import Data.List(foldl')


-- Invariant: The first field is the highest value in the Map
data Intern a = Intern {-# UNPACK #-} !Word32 !(Map.HashMap a Id)

newtype Id = Id Word32
    deriving (Id -> Id -> Bool
(Id -> Id -> Bool) -> (Id -> Id -> Bool) -> Eq Id
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Id -> Id -> Bool
$c/= :: Id -> Id -> Bool
== :: Id -> Id -> Bool
$c== :: Id -> Id -> Bool
Eq,Int -> Id -> Int
Id -> Int
(Int -> Id -> Int) -> (Id -> Int) -> Hashable Id
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Id -> Int
$chash :: Id -> Int
hashWithSalt :: Int -> Id -> Int
$chashWithSalt :: Int -> Id -> Int
Hashable,Eq Id
Eq Id
-> (Id -> Id -> Ordering)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Id)
-> (Id -> Id -> Id)
-> Ord Id
Id -> Id -> Bool
Id -> Id -> Ordering
Id -> Id -> Id
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Id -> Id -> Id
$cmin :: Id -> Id -> Id
max :: Id -> Id -> Id
$cmax :: Id -> Id -> Id
>= :: Id -> Id -> Bool
$c>= :: Id -> Id -> Bool
> :: Id -> Id -> Bool
$c> :: Id -> Id -> Bool
<= :: Id -> Id -> Bool
$c<= :: Id -> Id -> Bool
< :: Id -> Id -> Bool
$c< :: Id -> Id -> Bool
compare :: Id -> Id -> Ordering
$ccompare :: Id -> Id -> Ordering
$cp1Ord :: Eq Id
Ord,Get Id
[Id] -> Put
Id -> Put
(Id -> Put) -> Get Id -> ([Id] -> Put) -> Binary Id
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Id] -> Put
$cputList :: [Id] -> Put
get :: Get Id
$cget :: Get Id
put :: Id -> Put
$cput :: Id -> Put
Binary,Int -> Id -> ShowS
[Id] -> ShowS
Id -> String
(Int -> Id -> ShowS)
-> (Id -> String) -> ([Id] -> ShowS) -> Show Id
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Id] -> ShowS
$cshowList :: [Id] -> ShowS
show :: Id -> String
$cshow :: Id -> String
showsPrec :: Int -> Id -> ShowS
$cshowsPrec :: Int -> Id -> ShowS
Show,Id -> ()
(Id -> ()) -> NFData Id
forall a. (a -> ()) -> NFData a
rnf :: Id -> ()
$crnf :: Id -> ()
NFData,Ptr b -> Int -> IO Id
Ptr b -> Int -> Id -> IO ()
Ptr Id -> IO Id
Ptr Id -> Int -> IO Id
Ptr Id -> Int -> Id -> IO ()
Ptr Id -> Id -> IO ()
Id -> Int
(Id -> Int)
-> (Id -> Int)
-> (Ptr Id -> Int -> IO Id)
-> (Ptr Id -> Int -> Id -> IO ())
-> (forall b. Ptr b -> Int -> IO Id)
-> (forall b. Ptr b -> Int -> Id -> IO ())
-> (Ptr Id -> IO Id)
-> (Ptr Id -> Id -> IO ())
-> Storable Id
forall b. Ptr b -> Int -> IO Id
forall b. Ptr b -> Int -> Id -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
poke :: Ptr Id -> Id -> IO ()
$cpoke :: Ptr Id -> Id -> IO ()
peek :: Ptr Id -> IO Id
$cpeek :: Ptr Id -> IO Id
pokeByteOff :: Ptr b -> Int -> Id -> IO ()
$cpokeByteOff :: forall b. Ptr b -> Int -> Id -> IO ()
peekByteOff :: Ptr b -> Int -> IO Id
$cpeekByteOff :: forall b. Ptr b -> Int -> IO Id
pokeElemOff :: Ptr Id -> Int -> Id -> IO ()
$cpokeElemOff :: Ptr Id -> Int -> Id -> IO ()
peekElemOff :: Ptr Id -> Int -> IO Id
$cpeekElemOff :: Ptr Id -> Int -> IO Id
alignment :: Id -> Int
$calignment :: Id -> Int
sizeOf :: Id -> Int
$csizeOf :: Id -> Int
Storable)

empty :: Intern a
empty :: Intern a
empty = Word32 -> HashMap a Id -> Intern a
forall a. Word32 -> HashMap a Id -> Intern a
Intern Word32
0 HashMap a Id
forall k v. HashMap k v
Map.empty


insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a
insert :: a -> Id -> Intern a -> Intern a
insert a
k v :: Id
v@(Id Word32
i) (Intern Word32
n HashMap a Id
mp) = Word32 -> HashMap a Id -> Intern a
forall a. Word32 -> HashMap a Id -> Intern a
Intern (Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
n Word32
i) (HashMap a Id -> Intern a) -> HashMap a Id -> Intern a
forall a b. (a -> b) -> a -> b
$ a -> Id -> HashMap a Id -> HashMap a Id
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert a
k Id
v HashMap a Id
mp


add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)
add :: a -> Intern a -> (Intern a, Id)
add a
k (Intern Word32
v HashMap a Id
mp) = (Word32 -> HashMap a Id -> Intern a
forall a. Word32 -> HashMap a Id -> Intern a
Intern Word32
v2 (HashMap a Id -> Intern a) -> HashMap a Id -> Intern a
forall a b. (a -> b) -> a -> b
$ a -> Id -> HashMap a Id -> HashMap a Id
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert a
k (Word32 -> Id
Id Word32
v2) HashMap a Id
mp, Word32 -> Id
Id Word32
v2)
    where v2 :: Word32
v2 = Word32
v Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1


lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id
lookup :: a -> Intern a -> Maybe Id
lookup a
k (Intern Word32
_ HashMap a Id
mp) = a -> HashMap a Id -> Maybe Id
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup a
k HashMap a Id
mp


toList :: Intern a -> [(a, Id)]
toList :: Intern a -> [(a, Id)]
toList (Intern Word32
_ HashMap a Id
mp) = HashMap a Id -> [(a, Id)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap a Id
mp


fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a
fromList :: [(a, Id)] -> Intern a
fromList [(a, Id)]
xs = Word32 -> HashMap a Id -> Intern a
forall a. Word32 -> HashMap a Id -> Intern a
Intern ((Word32 -> Word32 -> Word32) -> Word32 -> [Word32] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
0 [Word32
i | (a
_, Id Word32
i) <- [(a, Id)]
xs]) ([(a, Id)] -> HashMap a Id
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(a, Id)]
xs)