#ifndef INCLUDEMETHOD
module Intel.CncUtil (
foldRange, for_, splitN, splitInclusiveRange, forkJoin,
doTrials, FitInWord (..),
GMapKey (..),
Hashable (..),
(!),
testCase,
tests,
MutableMap, newMutableMap, assureMvar, mmToList,
HotVar, newHotVar, modifyHotVar, modifyHotVar_,
)
where
#else
#warning "Loading CncUtil.hs through include method..."
#endif
import GHC.Conc
import Control.Concurrent
import Data.Time.Clock
import qualified Data.Map as DM
import qualified Data.IntMap as DI
import qualified Data.List as L
import Prelude hiding (lookup)
import Data.Char (ord,chr)
import Data.Word
import Data.Int
import Data.Bits
import Data.IORef
import qualified Data.HashTable as HT
import Debug.Trace
import Test.HUnit
foldRange start end acc fn = loop start acc
where
loop !i !acc
| i == end = acc
| otherwise = loop (i+1) (fn acc i)
for_ start end fn | start > end = error "for_: start is greater than end"
for_ start end fn = loop start
where
loop !i | i == end = return ()
| otherwise = do fn i; loop (i+1)
splitN :: Int -> [a] -> [[a]]
splitN n ls | n <= 0 = error "Cannot split list by a factor of 0"
splitN n ls = loop n ls
where
sz = length ls `quot` n
loop 1 ls = [ls]
loop n ls = hd : loop (n1) tl
where (hd,tl) = splitAt sz ls
splitInclusiveRange pieces (start,end) =
map largepiece [0..remain1] ++
map smallpiece [remain..pieces1]
where
len = end start + 1
(portion, remain) = len `quotRem` pieces
largepiece i =
let offset = start + (i * (portion + 1))
in (offset, offset + portion)
smallpiece i =
let offset = start + (i * portion) + remain
in (offset, offset + portion 1)
forkJoin actions =
do joiner <- newChan
mapM (\a -> forkIO (do a; writeChan joiner ())) actions
mapM_ (\_ -> readChan joiner) actions
return ()
t = forkJoin [putStrLn "foo", putStrLn "bar", putStrLn "baz"]
doTrials trials mnd =
sequence_ $ take trials $ repeat $
do putStrLn "------------------------------------------------------------"
strt <- getCurrentTime
mnd
end <- getCurrentTime
let diff = (diffUTCTime end strt)
putStrLn$ show diff ++ " real time consumed"
#ifdef HASHTABLE_TEST
type MutableMap a b = HashTable a (MVar b)
newMutableMap :: (Eq tag, Hashable tag) => IO (MutableMap tag b)
newMutableMap = HT.new (==) hash
assureMvar col tag =
do mayb <- HT.lookup col tag
case mayb of
Nothing -> do mvar <- newEmptyMVar
HT.insert col tag mvar
return mvar
Just mvar -> return mvar
mmToList = HT.toList
#warning "Enabling HashTable item collections. These are not truly thread safe (yet)."
#else
#ifdef USE_GMAP
#warning "Using experimental indexed type family GMap implementation..."
type MutableMap a b = IORef (GMap a (MVar b))
newMutableMap :: (GMapKey tag) => IO (MutableMap tag b)
newMutableMap = newIORef empty
assureMvar col tag =
do map <- readIORef col
case lookup tag map of
Nothing -> do mvar <- newEmptyMVar
atomicModifyIORef col
(\mp ->
let altered = alter
(\mv ->
case mv of
Nothing -> Just mvar
Just mv -> Just mv)
tag mp
in (altered, (!) altered tag))
Just mvar -> return mvar
mmToList col =
do map <- readIORef col
return (toList map)
#else
type MutableMap a b = IORef (DM.Map a (MVar b))
newMutableMap :: (Ord tag) => IO (MutableMap tag b)
newMutableMap = newIORef DM.empty
assureMvar col tag =
do map <- readIORef col
case DM.lookup tag map of
Nothing -> do mvar <- newEmptyMVar
atomicModifyIORef col
(\mp ->
let altered = DM.alter
(\mv ->
case mv of
Nothing -> Just mvar
Just mv -> Just mv)
tag mp
in (altered, (DM.!) altered tag))
Just mvar -> return mvar
mmToList col =
do map <- readIORef col
return (DM.toList map)
#endif
#endif
#define HOTVAR 1
newHotVar :: a -> IO (HotVar a)
modifyHotVar :: HotVar a -> (a -> (a,b)) -> IO b
modifyHotVar_ :: HotVar a -> (a -> a) -> IO ()
#if HOTVAR == 1
type HotVar a = IORef a
newHotVar = newIORef
modifyHotVar = atomicModifyIORef
modifyHotVar_ v fn = atomicModifyIORef v (\a -> (fn a, ()))
#elif HOTVAR == 2
#warning "Using MVars for hot atomic variables."
type HotVar a = MVar a
newHotVar = newMVar
modifyHotVar v fn = modifyMVar v (return . fn)
modifyHotVar_ v fn = modifyMVar_ v (return . fn)
#elif HOTVAR == 3
#warning "Using TVars for hot atomic variables."
type HotVar a = TVar a
newHotVar = newTVarIO
modifyHotVar tv fn = atomically (do x <- readTVar tv
let (x2,b) = fn x
writeTVar tv x2
return b)
modifyHotVar_ tv fn = atomically (do x <- readTVar tv; writeTVar tv (fn x))
#endif
class Hashable a where
hash :: a -> Int32
instance Hashable Bool where
hash True = 1
hash False = 0
instance Hashable Int where
hash = HT.hashInt
instance Hashable Char where
hash = HT.hashInt . fromEnum
instance Hashable Word16 where
hash = HT.hashInt . fromIntegral
instance Hashable [Char] where
hash = HT.hashString
instance (Hashable a, Hashable b) => Hashable (a,b) where
hash (a,b) = hash a + hash b
instance Hashable a => Hashable [a] where
hash [] = 0
hash (h:t) = hash h + hash t
class FitInWord v where
toWord :: v -> Word
fromWord :: Word -> v
intToWord :: Int -> Word
intToWord = fromIntegral
wordToInt :: Word -> Int
wordToInt = fromIntegral
instance FitInWord Char where
toWord = intToWord . ord
fromWord = chr . wordToInt
instance FitInWord Int where
toWord = fromIntegral
fromWord = fromIntegral
instance FitInWord Int16 where
toWord = fromIntegral
fromWord = fromIntegral
instance FitInWord Int8 where
toWord = fromIntegral
fromWord = fromIntegral
instance FitInWord Word8 where
toWord = fromIntegral
fromWord = fromIntegral
instance FitInWord Word16 where
toWord = fromIntegral
fromWord = fromIntegral
#ifdef x86_64_HOST_ARCH
instance FitInWord Int64 where
toWord = fromIntegral
fromWord = fromIntegral
instance FitInWord Word64 where
toWord = fromIntegral
fromWord = fromIntegral
#endif
instance FitInWord (Word16,Word16) where
toWord (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b)
fromWord n = (fromIntegral$ shiftR n 16,
fromIntegral$ n .&. 0xFFFF)
instance FitInWord (Int16,Int16) where
toWord (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b)
fromWord n = (fromIntegral$ shiftR n 16,
fromIntegral$ n .&. 0xFFFF)
class (Ord k, Eq k, Show k) => GMapKey k where
data GMap k :: * -> *
empty :: GMap k v
lookup :: k -> GMap k v -> Maybe v
insert :: k -> v -> GMap k v -> GMap k v
alter :: (Maybe a -> Maybe a) -> k -> GMap k a -> GMap k a
toList :: GMap k a -> [(k,a)]
#if 0
instance FitInWord t => GMapKey t where
data GMap t v = GMapInt (DI.IntMap v) deriving Show
empty = GMapInt DI.empty
lookup k (GMapInt m) = DI.lookup (wordToInt$ toWord k) m
insert k v (GMapInt m) = GMapInt (DI.insert (wordToInt$ toWord k) v m)
alter fn k (GMapInt m) = GMapInt (DI.alter fn (wordToInt$ toWord k) m)
toList (GMapInt m) = map (\ (i,v) -> (fromWord$ intToWord i, v)) $
DI.toList m
#else
instance GMapKey () where
data GMap () v = GMapUnit (Maybe v)
empty = GMapUnit Nothing
lookup () (GMapUnit v) = v
insert () v (GMapUnit _) = GMapUnit $ Just v
alter fn () (GMapUnit v) = GMapUnit $ fn v
toList (GMapUnit Nothing) = []
toList (GMapUnit (Just v)) = [((),v)]
instance GMapKey Bool where
data GMap Bool v = GMapBool (Maybe v) (Maybe v)
empty = GMapBool Nothing Nothing
lookup True (GMapBool v _) = v
lookup False (GMapBool _ v) = v
insert True v (GMapBool a b) = GMapBool (Just v) b
insert False v (GMapBool a b) = GMapBool a (Just v)
alter fn True (GMapBool a b) = GMapBool (fn a) b
alter fn False (GMapBool a b) = GMapBool a (fn b)
toList (GMapBool Nothing Nothing) = []
toList (GMapBool (Just a) Nothing) = [(True,a)]
toList (GMapBool Nothing (Just b)) = [(False,b)]
toList (GMapBool (Just a) (Just b)) = [(True,a),(False,b)]
instance GMapKey Int where
data GMap Int v = GMapInt (DI.IntMap v) deriving Show
empty = GMapInt DI.empty
lookup k (GMapInt m) = DI.lookup k m
insert k v (GMapInt m) = GMapInt (DI.insert k v m)
alter fn k (GMapInt m) = GMapInt (DI.alter fn k m)
toList (GMapInt m) = DI.toList m
instance GMapKey Char where
data GMap Char v = GMapChar (GMap Int v) deriving Show
empty = GMapChar empty
lookup k (GMapChar m) = lookup (ord k) m
insert k v (GMapChar m) = GMapChar (insert (ord k) v m)
alter fn k (GMapChar m) = GMapChar (alter fn (ord k) m)
toList (GMapChar m) = map (\ (i,v) -> (chr i,v)) (toList m)
instance GMapKey Word8 where
data GMap Word8 v = GMapWord8 (GMap Int v) deriving Show
empty = GMapWord8 empty
lookup k (GMapWord8 m) = lookup (fromIntegral k) m
insert k v (GMapWord8 m) = GMapWord8 (insert (fromIntegral k) v m)
alter fn k (GMapWord8 m) = GMapWord8 (alter fn (fromIntegral k) m)
toList (GMapWord8 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)
instance GMapKey Word16 where
data GMap Word16 v = GMapWord16 (GMap Int v) deriving Show
empty = GMapWord16 empty
lookup k (GMapWord16 m) = lookup (fromIntegral k) m
insert k v (GMapWord16 m) = GMapWord16 (insert (fromIntegral k) v m)
alter fn k (GMapWord16 m) = GMapWord16 (alter fn (fromIntegral k) m)
toList (GMapWord16 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)
instance GMapKey Word where
data GMap Word v = GMapWord (GMap Int v) deriving Show
empty = GMapWord empty
lookup k (GMapWord m) = lookup (fromIntegral k) m
insert k v (GMapWord m) = GMapWord (insert (fromIntegral k) v m)
alter fn k (GMapWord m) = GMapWord (alter fn (fromIntegral k) m)
toList (GMapWord m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)
instance GMapKey Int8 where
data GMap Int8 v = GMapInt8 (GMap Int v) deriving Show
empty = GMapInt8 empty
lookup k (GMapInt8 m) = lookup (fromIntegral k) m
insert k v (GMapInt8 m) = GMapInt8 (insert (fromIntegral k) v m)
alter fn k (GMapInt8 m) = GMapInt8 (alter fn (fromIntegral k) m)
toList (GMapInt8 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)
instance GMapKey Int16 where
data GMap Int16 v = GMapInt16 (GMap Int v) deriving Show
empty = GMapInt16 empty
lookup k (GMapInt16 m) = lookup (fromIntegral k) m
insert k v (GMapInt16 m) = GMapInt16 (insert (fromIntegral k) v m)
alter fn k (GMapInt16 m) = GMapInt16 (alter fn (fromIntegral k) m)
toList (GMapInt16 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)
#endif
instance (GMapKey a, GMapKey b) => GMapKey (a, b) where
data GMap (a, b) v = GMapPair (GMap a (GMap b v))
empty =
GMapPair empty
lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b
insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of
Nothing -> insert a (insert b v empty) gm
Just gm2 -> insert a (insert b v gm2 ) gm
alter fn (a, b) (GMapPair gm) = GMapPair $ alter newfun a gm
where
newfun entry =
case entry of
Nothing -> case fn Nothing of
Nothing -> Nothing
Just v -> Just $ insert b v empty
Just m -> Just$ alter fn b m
toList (GMapPair gm) = L.foldl' (\ acc (a,m) -> map (\ (b,v) -> ((a,b),v)) (toList m) ++ acc) [] $
toList gm
instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)
empty = GMapEither empty empty
lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1
lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2
insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2
insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2)
alter fn (Left a) (GMapEither gm1 gm2) = GMapEither (alter fn a gm1) gm2
alter fn (Right b) (GMapEither gm1 gm2) = GMapEither gm1 (alter fn b gm2)
toList (GMapEither gm1 gm2) =
map (\ (a,v) -> (Left a, v)) (toList gm1) ++
map (\ (b,v) -> (Right b, v)) (toList gm2)
instance (GMapKey a) => GMapKey [a] where
data GMap [a] v = GMapList (DM.Map [a] v) deriving Show
empty = GMapList DM.empty
lookup k (GMapList m) = DM.lookup k m
insert k v (GMapList m) = GMapList (DM.insert k v m)
alter fn k (GMapList m) = GMapList (DM.alter fn k m)
toList (GMapList m) = DM.toList m
(!) :: (GMapKey k) => GMap k v -> k -> v
(!) m k =
case lookup k m of
Nothing -> error "GMap (!) operator failed, element was not present."
Just x -> x
myGMap :: GMap (Int, Either Char ()) String
myGMap = insert (5, Left 'c') "(5, Left 'c')" $
insert (4, Right ()) "(4, Right ())" $
insert (5, Right ()) "This is the one!" $
insert (5, Right ()) "This is the two!" $
insert (6, Right ()) "(6, Right ())" $
insert (5, Left 'a') "(5, Left 'a')" $
empty
intMap :: GMap Int String
intMap = insert 3 "Entry 3" $
insert 4 "(4, Right ())" $
empty
class GMapKeyVal k v where
data GMap2 k v :: *
empty2 :: IO (GMap2 k v)
lookup2 :: k -> GMap2 k v -> IO (Maybe v)
insert2 :: k -> v -> GMap2 k v -> IO ()
test1gmap = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap
test2gmap = putStrLn $ maybe "Couldn't find key!" id $ lookup 3 intMap
testCase str io = TestLabel str $ TestCase$ do putStrLn$ "\n *** Running unit test: "++str; io; putStrLn ""
test1 = testCase "Spot check list lengths"$ assertEqual "splitN" [[1,2], [3,4,5]] (splitN 2 [1..5])
tests = TestList [test1]