module Name.Id(
Id(),
IdMap(),
IdNameT(),
IdSet(),
anonymous,
va1,va2,va3,va4,va5,
addBoundNamesIdMap,
addBoundNamesIdSet,
addNamesIdSet,
idMapToIdSet,
anonymousIds,
sillyId,
etherealIds,
isEtherealId,
isInvalidId,
isEmptyId,
idSetToIdMap,
mapMaybeIdMap,
idSetFromList,
idToInt,
idSetFromDistinctAscList,
idMapFromList,
idMapFromDistinctAscList,
idSetToList,
idMapToList,
emptyId,
newIds,
newId,
mixInt,
mixInt3,
toId,
fromId,
candidateIds,
runIdNameT
)where
import Control.Monad.Reader
import Control.Monad.State
import Data.Bits
import Data.Int
import Data.Monoid
import qualified Data.Binary as B
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Doc.DocLike
import Doc.PPrint
import Name.Name
import StringTable.Atom
import Util.HasSize
import Util.Inst()
import Util.NameMonad
import Util.SetLike as S
newtype Id = Id Int
deriving(Eq,Ord)
anonymous :: Int -> Id
anonymous x | x <= 0 = error "invalid anonymous id"
| otherwise = Id (2*x)
va1,va2,va3,va4,va5 :: Id
va1 = anonymous 1
va2 = anonymous 2
va3 = anonymous 3
va4 = anonymous 4
va5 = anonymous 5
instance Intjection Id where
toIntjection i = (Id i)
fromIntjection (Id i) = i
type IdSet = IntjectionSet Id
idSetToList :: IdSet -> [Id]
idSetToList = S.toList
idMapToList :: IdMap a -> [(Id,a)]
idMapToList = S.toList
idToInt :: Id -> Int
idToInt (Id x) = x
mapMaybeIdMap :: (a -> Maybe b) -> IdMap a -> IdMap b
mapMaybeIdMap fn (IntjectionMap m) = IntjectionMap (IM.mapMaybe fn m)
type IdMap = IntjectionMap Id
idSetToIdMap :: (Id -> a) -> IdSet -> IdMap a
idSetToIdMap f (IntjectionSet is) = IntjectionMap $ IM.fromDistinctAscList [ (x,f (Id x)) | x <- IS.toAscList is]
idMapToIdSet :: IdMap a -> IdSet
idMapToIdSet (IntjectionMap im) = IntjectionSet $ IM.keysSet im
newtype IdNameT m a = IdNameT (StateT (IdSet, IdSet) m a)
deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)
instance (MonadReader r m) => MonadReader r (IdNameT m) where
ask = lift ask
local f (IdNameT m) = IdNameT $ local f m
runIdNameT :: (Monad m) => IdNameT m a -> m (a,IdSet)
runIdNameT (IdNameT x) = do
(r,(used,bound)) <- runStateT x (mempty,mempty)
return (r,bound)
fromIdNameT (IdNameT x) = x
instance Monad m => NameMonad Id (IdNameT m) where
addNames ns = IdNameT $ do
modify (\ (used,bound) -> (fromList ns `union` used, bound) )
addBoundNames ns = IdNameT $ do
let nset = fromList ns
modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )
uniqueName n = IdNameT $ do
(used,bound) <- get
if n `member` bound then fromIdNameT newName else put (insert n used,insert n bound) >> return n
newNameFrom vs = IdNameT $ do
(used,bound) <- get
let f (x:xs)
| x `member` used = f xs
| otherwise = x
f [] = error "newNameFrom: finite list!"
nn = f vs
put (insert nn used, insert nn bound)
return nn
newName = IdNameT $ do
(used,bound) <- get
fromIdNameT $ newNameFrom (candidateIds (size used `mixInt` size bound))
addNamesIdSet nset = IdNameT $ do
modify (\ (used,bound) -> (nset `union` used, bound) )
addBoundNamesIdSet nset = IdNameT $ do
modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )
addBoundNamesIdMap nmap = IdNameT $ do
modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where
nset = idMapToIdSet nmap
idSetFromDistinctAscList :: [Id] -> IdSet
idSetFromDistinctAscList ids = IntjectionSet (IS.fromDistinctAscList [ x | Id x <- ids] )
idSetFromList :: [Id] -> IdSet
idSetFromList ids = fromList ids
idMapFromList :: [(Id,a)] -> IdMap a
idMapFromList ids = fromList ids
idMapFromDistinctAscList :: [(Id,a)] -> IdMap a
idMapFromDistinctAscList ids = IntjectionMap (IM.fromDistinctAscList [ (x,y) | (Id x,y) <- ids ] )
instance Show Id where
showsPrec _ (Id 0) = showChar '_'
showsPrec _ (Id x) = maybe (showString ('x':show (x `div` 2))) shows (fromId $ Id x)
instance Show IdSet where
showsPrec n is = showsPrec n (idSetToList is)
instance Show v => Show (IdMap v) where
showsPrec n is = showsPrec n (idMapToList is)
anonymousIds :: [Id]
anonymousIds = map anonymous [1 .. ]
etherealIds :: [Id]
etherealIds = map Id [4, 6 .. ]
isEmptyId x = x == emptyId
isEtherealId id = id < emptyId
isInvalidId id = id <= emptyId
sillyId :: Id
sillyId = Id $ 2
emptyId :: Id
emptyId = Id 0
newIds :: IdSet -> [Id]
newIds (IntjectionSet ids) = ans where
ans = if sids == 0 then candidateIds 42 else [ Id i | Id i <- candidates, i `notMember` ids ]
sids = size ids
candidates = candidateIds (mixInt3 sids (IS.findMin ids) (IS.findMax ids))
newId :: Int
-> (Id -> Bool)
-> Id
newId seed check = head $ filter check (candidateIds seed)
candidateIds :: Int -> [Id]
candidateIds !seed = f (2 + (mask $ hashInt seed)) where
mask x = x .&. 0x0FFFFFFE
f !x = Id x:f (x + 2)
toId :: Name -> Id
toId x = Id $ fromAtom (toAtom x)
instance FromAtom Id where
fromAtom x = Id $ fromAtom x
fromId :: Monad m => Id -> m Name
fromId (Id i) = case intToAtom i of
Just a -> return $ fromAtom a
Nothing -> fail $ "Name.fromId: not a name " ++ show (Id i)
instance DocLike d => PPrint d Id where
pprint x = tshow x
instance GenName Id where
genNames = candidateIds
instance B.Binary Id where
put (Id x) = case intToAtom x of
Just a -> do B.putWord8 128 >> B.put a
Nothing | x >= 0 && x < 128 -> B.putWord8 (fromIntegral x)
| otherwise -> do
B.putWord8 129
B.put (fromIntegral x :: Int32)
get = do
x <- B.getWord8
case x of
128 -> do
a <- B.get
return (toId $ fromAtom a)
129 -> do
v <- B.get
return (Id $ fromIntegral (v :: Int32))
_ -> return (Id $ fromIntegral x)