Show
Ignore:
Timestamp:
04/28/05 18:38:12 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
3914
Message:

* AST.hs-boot elimianted!

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Types/Hash.hs

    r2433 r2441  
    1 {-# OPTIONS_GHC -fglasgow-exts #-} 
     1type HashIndex = VStr 
    22 
    3 module Pugs.Types.Hash where 
     3class (Typeable a) => HashClass a where 
     4    hash_iType :: a -> Type 
     5    hash_iType = const $ mkType "Hash" 
     6    hash_fetch       :: a -> Eval VHash 
     7    hash_fetch hv = do 
     8        keys <- hash_fetchKeys hv 
     9        vals <- mapM (hash_fetchVal hv) keys 
     10        return . Map.fromList $ keys `zip` vals 
     11    hash_store       :: a -> VHash -> Eval () 
     12    hash_store hv vals = do 
     13        hash_clear hv 
     14        forM_ (Map.assocs vals) $ \(key, val) -> do 
     15            hash_storeVal hv key val 
     16    hash_fetchElem   :: a -> HashIndex -> Eval (IVar VScalar) -- autovivify 
     17    hash_fetchElem hv key = do 
     18        return $ proxyScalar (hash_fetchVal hv key) (hash_storeVal hv key) 
     19    hash_storeElem   :: a -> HashIndex -> IVar VScalar -> Eval () -- binding 
     20    hash_storeElem hv idx sv = do 
     21        val <- readIVar sv 
     22        hash_storeVal hv idx val 
     23    hash_fetchVal    :: a -> HashIndex -> Eval Val 
     24    hash_fetchVal hv key = do 
     25        rv <- hash_existsElem hv key 
     26        if rv then readIVar =<< hash_fetchElem hv key 
     27              else return undef 
     28    hash_storeVal    :: a -> HashIndex -> Val -> Eval () 
     29    hash_storeVal hv key val = do 
     30        sv <- hash_fetchElem hv key 
     31        writeIVar sv val 
     32    hash_fetchKeys   :: a -> Eval [HashIndex] 
     33    hash_fetchKeys hv = do 
     34        vals <- hash_fetch hv 
     35        return $ Map.keys vals 
     36    hash_deleteElem  :: a -> HashIndex -> Eval () 
     37    hash_existsElem  :: a -> HashIndex -> Eval VBool 
     38    hash_existsElem hv idx = do 
     39        keys <- hash_fetchKeys hv 
     40        return $ idx `elem` keys 
     41    hash_clear       :: a -> Eval () 
     42    hash_clear hv = do 
     43        keys <- hash_fetchKeys hv 
     44        mapM_ (hash_deleteElem hv) keys 
     45    hash_isEmpty     :: a -> Eval VBool 
     46    hash_isEmpty hv = do 
     47        keys <- hash_fetchKeys hv 
     48        return $ null keys  
    449 
    5 import {-# SOURCE #-} Pugs.AST 
    6 import Pugs.Internals 
    7 import Pugs.Types 
    8 import qualified Data.Map as Map 
     50instance HashClass (IVar VPair) where 
     51    hash_iType = const $ mkType "Pair" 
     52    hash_fetch pv = do 
     53        (k, v)  <- readIVar pv 
     54        str     <- fromVal k 
     55        return $ Map.singleton str v 
     56    hash_fetchVal pv idx = do 
     57        (k, v)  <- readIVar pv 
     58        str     <- fromVal k 
     59        if str == idx 
     60            then return v 
     61            else return undef 
     62    hash_storeVal _ _ _ = retConstError undef 
     63    hash_deleteElem _ _ = retConstError undef 
    964 
    10 type Index = VStr 
     65instance HashClass VHash where 
     66    hash_iType = const $ mkType "Hash::Const" 
     67    hash_fetch = return 
     68    hash_fetchKeys = return . Map.keys 
     69    hash_fetchVal hv idx = return $ Map.findWithDefault undef idx hv 
     70    hash_clear _ = retConstError undef 
     71    hash_store _ _ = retConstError undef 
     72    hash_storeVal _ _ _ = retConstError undef 
     73    hash_storeElem _ _ _ = retConstError undef 
     74    hash_deleteElem _ _ = retConstError undef 
    1175 
    12 class (Typeable a) => Class a where 
    13     iType :: a -> Type 
    14     iType = const $ mkType "Hash" 
    15     fetch       :: a -> Eval VHash 
    16     fetch hv = do 
    17         keys <- fetchKeys hv 
    18         vals <- mapM (fetchVal hv) keys 
    19         return . Map.fromList $ keys `zip` vals 
    20     store       :: a -> VHash -> Eval () 
    21     store hv vals = do 
    22         clear hv 
    23         forM_ (Map.assocs vals) $ \(key, val) -> do 
    24             storeVal hv key val 
    25     fetchElem   :: a -> Index -> Eval (IVar VScalar) -- autovivify 
    26     fetchElem hv key = do 
    27         return $ proxyScalar (fetchVal hv key) (storeVal hv key) 
    28     storeElem   :: a -> Index -> IVar VScalar -> Eval () -- binding 
    29     storeElem hv idx sv = do 
    30         val <- readIVar sv 
    31         storeVal hv idx val 
    32     fetchVal    :: a -> Index -> Eval Val 
    33     fetchVal hv key = do 
    34         rv <- existsElem hv key 
    35         if rv then readIVar =<< fetchElem hv key 
    36               else return undef 
    37     storeVal    :: a -> Index -> Val -> Eval () 
    38     storeVal hv key val = do 
    39         sv <- fetchElem hv key 
    40         writeIVar sv val 
    41     fetchKeys   :: a -> Eval [Index] 
    42     fetchKeys hv = do 
    43         vals <- fetch hv 
    44         return $ Map.keys vals 
    45     deleteElem  :: a -> Index -> Eval () 
    46     existsElem  :: a -> Index -> Eval VBool 
    47     existsElem hv idx = do 
    48         keys <- fetchKeys hv 
    49         return $ idx `elem` keys 
    50     clear       :: a -> Eval () 
    51     clear hv = do 
    52         keys <- fetchKeys hv 
    53         mapM_ (deleteElem hv) keys 
    54     isEmpty     :: a -> Eval VBool 
    55     isEmpty hv = do 
    56         keys <- fetchKeys hv 
    57         return $ null keys  
     76instance HashClass IHashEnv where 
     77    hash_iType = const $ mkType "Hash::Env" 
     78    hash_fetch _ = do 
     79        envs <- liftIO getEnvironment 
     80        return . Map.map VStr $ Map.fromList envs 
     81    hash_fetchVal _ key = tryIO undef $ do 
     82        str <- getEnv key 
     83        return $ VStr str 
     84    hash_storeVal _ key val = do 
     85        str <- fromVal val 
     86        liftIO $ setEnv key str True 
     87    hash_existsElem _ key = tryIO False $ do 
     88        getEnv key 
     89        return True 
     90    hash_deleteElem _ key = do 
     91        liftIO $ unsetEnv key 
     92 
     93instance HashClass IHash where 
     94    hash_fetch hv = do 
     95        svMap <- liftSTM $ readTVar hv 
     96        fmap Map.fromList $ forM (Map.assocs svMap) $ \(key, sv) -> do 
     97            val <- readIVar sv 
     98            return (key, val) 
     99    hash_fetchKeys hv = do 
     100        liftSTM . fmap Map.keys $ readTVar hv 
     101    hash_fetchElem hv idx = do 
     102        svMap <- liftSTM $ readTVar hv 
     103        case Map.lookup idx svMap of 
     104            Just sv -> return sv 
     105            Nothing -> do 
     106                sv <- newScalar undef 
     107                liftSTM $ modifyTVar hv (Map.insert idx sv) 
     108                return sv 
     109    hash_storeElem hv idx sv = do 
     110        liftSTM $ modifyTVar hv (Map.insert idx sv) 
     111    hash_deleteElem hv idx = do 
     112        liftSTM $ modifyTVar hv (Map.delete idx) 
     113    hash_existsElem hv idx = do 
     114        liftSTM $ do 
     115            svMap <- readTVar hv 
     116            return $ Map.member idx svMap