UID.hs

module UHC.Light.Compiler.Base.UID
( mkNewLevUID, mkNewLevUID2, mkNewLevUID3, mkNewLevUID4, mkNewLevUID5, mkNewLevUID6, mkNewLevUID7, mkNewLevUID8, uidNext, mkNewUID, mkNewUIDL, uidNull, uidChild, mkInfNewUIDL
, FreshUidT, FreshUid, runFreshUidT, runFreshUid, evalFreshUid
, MonadFreshUID (..)
, UID (..)
, mkUID
, uidFromInt
, uidStart, uidUnused
, nextUnique
, UIDS
, mkNewLevUIDL, mkInfNewLevUIDL
, showUIDParseable, ppUIDParseable
, uidSimplifications )
where
import UHC.Util.Pretty
import UHC.Util.Hashable
import qualified Data.Set as Set
import Data.List
import Control.Monad.State
import Control.Monad.Identity
import Data.Typeable (Typeable)
import Data.Generics (Data)
import GHC.Generics
import Control.Monad
import UHC.Util.Binary as B
import UHC.Util.Serialize





{-# LINE 41 "src/ehc/Base/UID.chs" #-}
type FreshUidT m   = StateT UID m
type FreshUid      = FreshUidT Identity

{-
freshUID :: MonadState UID m => m UID
freshUID = state $ \x -> (x, uidNext x)
-}

runFreshUidT :: Monad m => FreshUidT m a -> UID -> m (a,UID)
runFreshUidT f u = runStateT f u
{-# INLINE runFreshUidT #-}

runFreshUid :: FreshUid a -> UID -> (a,UID)
runFreshUid f u = runIdentity $ runFreshUidT f u
{-# INLINE runFreshUid #-}

evalFreshUid :: FreshUid a -> UID -> a
evalFreshUid f u = fst $ runIdentity $ runFreshUidT f u
{-# INLINE evalFreshUid #-}

{-# LINE 63 "src/ehc/Base/UID.chs" #-}
class Monad m => MonadFreshUID m where
  -- | Fresh single UID
  freshUID :: m UID
  freshUID = freshInfUID

  -- | Fresh infinite range of UID
  freshInfUID :: m UID
  freshInfUID = freshUID

-- TBD: flip results of mkNewLevUID (etc) to be in agreement with behavior of state
instance Monad m => MonadFreshUID (FreshUidT m) where
  freshUID = state $ \x -> (x, uidNext x)
  {-# INLINE freshUID #-}

  freshInfUID = state $ \x -> (uidChild x, uidNext x)
  {-# INLINE freshInfUID #-}

{-# LINE 87 "src/ehc/Base/UID.chs" #-}
data UID = UID { uidHash :: !Int, uidInts :: ![Int] }
  deriving (Eq,Ord,Generic)

{-# LINE 96 "src/ehc/Base/UID.chs" #-}
mkUID :: [Int] -> UID
mkUID is = UID (hash is) is

{-# LINE 105 "src/ehc/Base/UID.chs" #-}
type UIDL = [UID]

{-# LINE 109 "src/ehc/Base/UID.chs" #-}
type UIDS = Set.Set UID

{-# LINE 113 "src/ehc/Base/UID.chs" #-}
instance Show UID where
  show uid = concat . intersperse "_" . map show . reverse $ uidInts uid

{-# LINE 118 "src/ehc/Base/UID.chs" #-}
instance Hashable UID where
  hashWithSalt salt (UID h _) = salt `hashWithSalt` h

{-# LINE 127 "src/ehc/Base/UID.chs" #-}
uidNext :: UID -> UID
uidNext (UID _ (n:ns)) = mkUID (n+1:ns)

uidChild :: UID -> UID
uidChild (UID _ ns) = mkUID (0:ns)

{-# LINE 143 "src/ehc/Base/UID.chs" #-}
mkNewLevUID :: UID -> (UID,UID)
mkNewLevUID u = (uidNext u, uidChild u)

{-# LINE 148 "src/ehc/Base/UID.chs" #-}
uidFromInt :: Int -> UID
uidFromInt i = mkUID [i]

{-# LINE 153 "src/ehc/Base/UID.chs" #-}
uidStart :: UID
uidStart = uidFromInt 0

uidUnused :: UID
uidUnused = uidFromInt (-1)

{-# LINE 161 "src/ehc/Base/UID.chs" #-}
mkNewLevUID2 u = let { (u',u1)          = mkNewLevUID   u; (u'',u2)          = mkNewLevUID   u'} in (u'',u1,u2)
mkNewLevUID3 u = let { (u',u1,u2)       = mkNewLevUID2  u; (u'',u3)          = mkNewLevUID   u'} in (u'',u1,u2,u3)
mkNewLevUID4 u = let { (u',u1,u2)       = mkNewLevUID2  u; (u'',u3,u4)       = mkNewLevUID2  u'} in (u'',u1,u2,u3,u4)
mkNewLevUID5 u = let { (u',u1,u2)       = mkNewLevUID2  u; (u'',u3,u4,u5)    = mkNewLevUID3  u'} in (u'',u1,u2,u3,u4,u5)
mkNewLevUID6 u = let { (u',u1,u2,u3)    = mkNewLevUID3  u; (u'',u4,u5,u6)    = mkNewLevUID3  u'} in (u'',u1,u2,u3,u4,u5,u6)
mkNewLevUID7 u = let { (u',u1,u2,u3,u4) = mkNewLevUID4  u; (u'',u5,u6,u7)    = mkNewLevUID3  u'} in (u'',u1,u2,u3,u4,u5,u6,u7)
mkNewLevUID8 u = let { (u',u1,u2,u3,u4) = mkNewLevUID4  u; (u'',u5,u6,u7,u8) = mkNewLevUID4  u'} in (u'',u1,u2,u3,u4,u5,u6,u7,u8)

uidNull :: UID
uidNull  = mkUID []

mkNewUID :: UID -> (UID,UID)
mkNewUID   uid = (uidNext uid,uid)

mkInfNewUIDL' :: (UID -> (UID,UID)) -> UID -> [UID]
mkInfNewUIDL' mk uid
  =  let  l = drop 1 $ iterate (\(nxt,uid) -> mk nxt) $ mkNewUID uid
     in   map snd l

mkNewUIDL' :: (UID -> (UID,UID)) -> Int -> UID -> [UID] -- assume sz > 0
mkNewUIDL' mk sz uid
  =  take sz (mkInfNewUIDL' mk uid)

mkNewUIDL :: Int -> UID -> [UID] -- assume sz > 0
mkNewUIDL = mkNewUIDL' mkNewUID

mkInfNewUIDL :: UID -> [UID]
mkInfNewUIDL = mkInfNewUIDL' mkNewUID

instance PP UID where
  pp = text . show

{-# LINE 195 "src/ehc/Base/UID.chs" #-}
-- | Inverse of pUID
showUIDParseable :: UID -> String
-- showUIDParseable uid = "%[" ++ (concat $ intersperse "/" $ map show $ uidInts uid) ++ "]"
showUIDParseable uid = "`{" ++ (concat $ intersperse "," $ map show $ uidInts uid) ++ "}"

-- | Inverse of pUID
ppUIDParseable :: UID -> PP_Doc
ppUIDParseable = pp . showUIDParseable

{-# LINE 206 "src/ehc/Base/UID.chs" #-}
mkInfNewLevUIDL :: UID -> [UID]
mkInfNewLevUIDL = mkInfNewUIDL' mkNewLevUID

mkNewLevUIDL :: Int -> UID -> [UID]
mkNewLevUIDL = mkNewUIDL' mkNewLevUID

{-# LINE 218 "src/ehc/Base/UID.chs" #-}
-- | Simplifications obtained by omitting all but 1 of the Int's, then re-adding one by one, omitting the original
uidSimplifications :: UID -> [UID]
uidSimplifications = map (mkUID . reverse) . drop 1 . init . inits . reverse . uidInts

{-# LINE 228 "src/ehc/Base/UID.chs" #-}
nextUnique = mkNewLevUID

{-# LINE 236 "src/ehc/Base/UID.chs" #-}
deriving instance Typeable UID

{-# LINE 253 "src/ehc/Base/UID.chs" #-}
instance Binary UID where
  put (UID a b) = B.put a >> B.put b
  get = liftM2 UID B.get B.get

instance Serialize UID where
  sput = sputShared
  sget = sgetShared
  sputNested = sputPlain
  sgetNested = sgetPlain