Changeset 2441 for src/Pugs/Types

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

* AST.hs-boot elimianted!

Location:
src/Pugs/Types
Files:
9 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Types/Array.hs

    r2221 r2441  
    1 {-# OPTIONS_GHC -fglasgow-exts #-} 
    2  
    3 module Pugs.Types.Array where 
    4  
    5 import {-# SOURCE #-} Pugs.AST 
    6 import Pugs.Internals 
    7 import Pugs.Types 
    8  
    9 type Index = Int 
    10  
    11 class (Typeable a) => Class a where 
    12     iType :: a -> Type 
    13     iType = const $ mkType "Array" 
    14     fetch       :: a -> Eval VArray 
    15     fetch av = do 
    16         size <- fetchSize av 
    17         mapM (fetchVal av) [0..size-1] 
    18     store       :: a -> VArray -> Eval () 
    19     store av list = do 
     1type ArrayIndex = Int 
     2 
     3class (Typeable a) => ArrayClass a where 
     4    array_iType :: a -> Type 
     5    array_iType = const $ mkType "Array" 
     6    array_fetch       :: a -> Eval VArray 
     7    array_fetch av = do 
     8        size <- array_fetchSize av 
     9        mapM (array_fetchVal av) [0..size-1] 
     10    array_store       :: a -> VArray -> Eval () 
     11    array_store av list = do 
    2012        forM_ ([0..] `zip` list) $ \(idx, val) -> do 
    21             sv <- fetchElem av idx 
     13            sv <- array_fetchElem av idx 
    2214            writeIVar sv val 
    23         storeSize av (length list) 
    24     fetchKeys   :: a -> Eval [Index] 
    25     fetchKeys av = do 
    26         svList <- fetch av 
     15        array_storeSize av (length list) 
     16    array_fetchKeys   :: a -> Eval [ArrayIndex] 
     17    array_fetchKeys av = do 
     18        svList <- array_fetch av 
    2719        return $ zipWith const [0..] svList 
    28     fetchElem   :: a -> Index -> Eval (IVar VScalar) -- autovivify 
    29     fetchElem av idx = do 
    30         return $ proxyScalar (fetchVal av idx) (storeVal av idx) 
    31     storeElem   :: a -> Index -> IVar VScalar -> Eval () -- binding 
    32     storeElem av idx sv = do 
     20    array_fetchElem   :: a -> ArrayIndex -> Eval (IVar VScalar) -- autovivify 
     21    array_fetchElem av idx = do 
     22        return $ proxyScalar (array_fetchVal av idx) (array_storeVal av idx) 
     23    array_storeElem   :: a -> ArrayIndex -> IVar VScalar -> Eval () -- binding 
     24    array_storeElem av idx sv = do 
    3325        val <- readIVar sv 
    34         storeVal av idx val 
    35     fetchVal    :: a -> Index -> Eval Val 
    36     fetchVal av idx = do 
    37         rv <- existsElem av idx 
    38         if rv then readIVar =<< fetchElem av idx 
     26        array_storeVal av idx val 
     27    array_fetchVal    :: a -> ArrayIndex -> Eval Val 
     28    array_fetchVal av idx = do 
     29        rv <- array_existsElem av idx 
     30        if rv then readIVar =<< array_fetchElem av idx 
    3931              else return undef 
    40     storeVal    :: a -> Index -> Val -> Eval () 
    41     storeVal av idx val = do 
    42         sv <- fetchElem av idx 
     32    array_storeVal    :: a -> ArrayIndex -> Val -> Eval () 
     33    array_storeVal av idx val = do 
     34        sv <- array_fetchElem av idx 
    4335        writeIVar sv val 
    44     fetchSize   :: a -> Eval Index 
    45     fetchSize av = do 
    46         vals <- fetch av 
     36    array_fetchSize   :: a -> Eval ArrayIndex 
     37    array_fetchSize av = do 
     38        vals <- array_fetch av 
    4739        return $ length vals 
    48     storeSize   :: a -> Index -> Eval () 
    49     storeSize av sz = do 
    50         size <- fetchSize av 
     40    array_storeSize   :: a -> ArrayIndex -> Eval () 
     41    array_storeSize av sz = do 
     42        size <- array_fetchSize av 
    5143        case size `compare` sz of 
    52             GT -> mapM_ (const $ pop av) [size .. sz-1] 
     44            GT -> mapM_ (const $ array_pop av) [size .. sz-1] 
    5345            EQ -> return () -- no need to do anything 
    54             LT -> mapM_ (\idx -> storeElem av idx lazyUndef) [size .. sz-1] 
    55     extendSize  :: a -> Index -> Eval () 
    56     extendSize _ 0 = return () 
    57     extendSize av sz = do 
    58         size <- fetchSize av 
     46            LT -> mapM_ (\idx -> array_storeElem av idx lazyUndef) [size .. sz-1] 
     47    array_extendSize  :: a -> ArrayIndex -> Eval () 
     48    array_extendSize _ 0 = return () 
     49    array_extendSize av sz = do 
     50        size <- array_fetchSize av 
    5951        when (size < sz) $ do 
    60             mapM_ (\idx -> storeElem av idx lazyUndef) [size .. sz-1] 
    61     deleteElem  :: a -> Index -> Eval () 
    62     deleteElem av idx = do 
    63         size <- fetchSize av 
     52            mapM_ (\idx -> array_storeElem av idx lazyUndef) [size .. sz-1] 
     53    array_deleteElem  :: a -> ArrayIndex -> Eval () 
     54    array_deleteElem av idx = do 
     55        size <- array_fetchSize av 
    6456        let idx' = if idx < 0 then idx `mod` size else idx 
    6557        case (size - 1) `compare` idx' of 
    6658            GT -> return ()                             -- no such index 
    67             EQ -> storeSize av (size - 1)               -- truncate 
    68             LT -> storeElem av idx' lazyUndef            -- set to undef 
    69     existsElem  :: a -> Index -> Eval VBool 
    70     existsElem av idx = do 
    71         size <- fetchSize av 
     59            EQ -> array_storeSize av (size - 1)               -- truncate 
     60            LT -> array_storeElem av idx' lazyUndef            -- set to undef 
     61    array_existsElem  :: a -> ArrayIndex -> Eval VBool 
     62    array_existsElem av idx = do 
     63        size <- array_fetchSize av 
    7264        return $ size > (if idx < 0 then idx `mod` size else idx) 
    73     clear       :: a -> Eval () 
    74     clear av = storeSize av 0 
    75     push        :: a -> [Val] -> Eval () 
    76     push av vals = do 
    77         size <- fetchSize av 
     65    array_clear       :: a -> Eval () 
     66    array_clear av = array_storeSize av 0 
     67    array_push        :: a -> [Val] -> Eval () 
     68    array_push av vals = do 
     69        size <- array_fetchSize av 
    7870        forM_ ([size..] `zip` vals) $ \(idx, val) -> do 
    79             storeElem av idx (lazyScalar val) 
    80     pop         :: a -> Eval Val 
    81     pop av = do 
    82         size <- fetchSize av 
     71            array_storeElem av idx (lazyScalar val) 
     72    array_pop         :: a -> Eval Val 
     73    array_pop av = do 
     74        size <- array_fetchSize av 
    8375        if size == 0 
    8476            then return undef 
    8577            else do 
    86                 sv <- fetchElem av $ size - 1 
    87                 storeSize av $ size - 1 
     78                sv <- array_fetchElem av $ size - 1 
     79                array_storeSize av $ size - 1 
    8880                readIVar sv 
    89     shift       :: a -> Eval Val 
    90     shift av = do 
    91         vals <- splice av 0 1 [] 
     81    array_shift       :: a -> Eval Val 
     82    array_shift av = do 
     83        vals <- array_splice av 0 1 [] 
    9284        return $ last (undef:vals) 
    93     unshift     :: a -> [Val] -> Eval () 
    94     unshift av vals = do 
    95         splice av 0 0 vals 
     85    array_unshift     :: a -> [Val] -> Eval () 
     86    array_unshift av vals = do 
     87        array_splice av 0 0 vals 
    9688        return () 
    97     splice      :: a -> Index -> Index -> [Val] -> Eval [Val] 
    98     splice av off len vals = do 
    99         size <- fetchSize av 
     89    array_splice      :: a -> ArrayIndex -> ArrayIndex -> [Val] -> Eval [Val] 
     90    array_splice av off len vals = do 
     91        size <- array_fetchSize av 
    10092        let off' = if off < 0 then off + size else off 
    10193            len' = if len < 0 then len + size - off' else len 
    102         result <- mapM (fetchElem av) [off' .. off' + len' - 1] 
     94        result <- mapM (array_fetchElem av) [off' .. off' + len' - 1] 
    10395        let off = if off' > size then size else off' 
    10496            len = if off + len' > size then size - off else len' 
    … …  
    108100                -- Move items up to make room 
    109101                let delta = cnt - len 
    110                 extendSize av (size + delta) 
     102                array_extendSize av (size + delta) 
    111103                (`mapM_` reverse [off + len .. size - 1]) $ \idx -> do 
    112                     val <- fetchElem av idx 
    113                     storeElem av (idx + delta) val 
     104                    val <- array_fetchElem av idx 
     105                    array_storeElem av (idx + delta) val 
    114106            LT -> do 
    115107                let delta = len - cnt 
    116108                (`mapM_` [off + len .. size - 1]) $ \idx -> do 
    117                     val <- fetchElem av idx 
    118                     storeElem av (idx - delta) val 
    119                 storeSize av (size - delta) 
     109                    val <- array_fetchElem av idx 
     110                    array_storeElem av (idx - delta) val 
     111                array_storeSize av (size - delta) 
    120112            _ -> return () 
    121113        forM_ ([0..] `zip` vals) $ \(idx, val) -> do 
    122             storeElem av (off + idx) (lazyScalar val) 
     114            array_storeElem av (off + idx) (lazyScalar val) 
    123115        mapM readIVar result 
     116 
     117instance ArrayClass IArraySlice where 
     118    array_iType = const $ mkType "Array::Slice" 
     119    array_store av vals = mapM_ (uncurry writeIVar) (zip av vals) 
     120    array_fetchSize = return . length 
     121    array_fetchElem av idx = getIndex idx Nothing (return av) Nothing 
     122    array_storeSize _ _ = return () -- XXX error? 
     123    array_storeElem _ _ _ = retConstError undef 
     124 
     125instance ArrayClass IArray where 
     126    array_store av vals = do 
     127        let svList = map lazyScalar vals 
     128        liftSTM $ writeTVar av svList 
     129    array_fetchSize av = do 
     130        svList <- liftSTM $ readTVar av 
     131        return $ length svList 
     132    array_storeSize av sz = do 
     133        liftSTM $ modifyTVar av $ take sz . (++ repeat lazyUndef) 
     134    array_shift av = do 
     135        svList <- liftSTM $ readTVar av 
     136        case svList of 
     137            (sv:rest) -> do 
     138                liftSTM $ writeTVar av rest 
     139                readIVar sv 
     140            _ -> return undef 
     141    array_unshift av vals = do 
     142        liftSTM $ modifyTVar av 
     143            (map lazyScalar vals ++) 
     144    array_extendSize _ 0 = return () 
     145    array_extendSize av sz = do 
     146        liftSTM . modifyTVar av $ \svList -> 
     147            if null $ drop (sz-1) svList 
     148                then take sz (svList ++ repeat lazyUndef) 
     149                else svList 
     150    array_fetchVal av idx = do 
     151        readIVar =<< getIndex idx (Just $ constScalar undef) 
     152            (liftSTM $ readTVar av)  
     153            Nothing -- don't bother extending 
     154    array_fetchKeys av = do 
     155        svList <- liftSTM $ readTVar av 
     156        return $ zipWith const [0..] svList 
     157    array_fetchElem av idx = do 
     158        sv <- getIndex idx Nothing 
     159            (liftSTM $ readTVar av)  
     160            (Just (array_extendSize av $ idx+1)) 
     161        if refType (MkRef sv) == mkType "Scalar::Lazy" 
     162            then do 
     163                val <- readIVar sv 
     164                sv' <- newScalar val 
     165                liftSTM . modifyTVar av $ \svList -> 
     166                    let idx' = idx `mod` length svList in 
     167                    take idx' svList ++ (sv' : drop (idx'+1) svList) 
     168                return sv' 
     169            else return sv 
     170    array_existsElem av idx | idx < 0 = array_existsElem av (abs idx - 1) 
     171    array_existsElem av idx = do 
     172        svList <- liftSTM $ readTVar av 
     173        return . not . null $ drop idx svList 
     174    array_deleteElem av idx = do 
     175        liftSTM . modifyTVar av $ \svList -> 
     176            let idx' | idx < 0   = idx `mod` length svList -- XXX wrong; wraparound 
     177                     | otherwise = idx in 
     178            if null $ drop (idx' + 1) svList 
     179                then take idx' svList 
     180                else take idx' svList ++ (lazyUndef : drop (idx'+1) svList) 
     181    array_storeElem av idx sv = do 
     182        liftSTM . modifyTVar av $ \svList -> 
     183            let idx' | idx < 0   = idx `mod` length svList -- XXX wrong; wraparound 
     184                     | otherwise = idx in 
     185            take idx svList ++ (sv : drop (idx'+1) svList) 
     186 
     187instance ArrayClass VArray where 
     188    array_iType = const $ mkType "Array::Const" 
     189    array_store [] _ = return () 
     190    array_store _ [] = return () 
     191    array_store (a:as) vals@(v:vs) = do 
     192        env <- ask 
     193        ref <- fromVal a 
     194        if isaType (envClasses env) "List" (refType ref) 
     195            then writeRef ref (VList vals) 
     196            else do 
     197                writeRef ref v 
     198                array_store as vs 
     199    array_fetch = return 
     200    array_fetchSize = return . length 
     201    array_fetchVal av idx = getIndex idx (Just undef) (return av) Nothing 
     202    array_storeVal _ _ _ = retConstError undef 
     203    array_storeElem _ _ _ = retConstError undef 
     204 
     205instance ArrayClass (IVar VPair) where 
     206    array_iType = const $ mkType "Pair" 
     207    array_fetch pv = do 
     208        (k, v)  <- readIVar pv 
     209        return [k, v] 
     210    array_existsElem _ idx = return (idx >= -2 || idx <= 1) 
     211    array_fetchSize        = const $ return 2 
     212    array_fetchVal pv (-2) = return . fst =<< readIVar pv 
     213    array_fetchVal pv (-1) = return . snd =<< readIVar pv 
     214    array_fetchVal pv 0    = return . fst =<< readIVar pv 
     215    array_fetchVal pv 1    = return . snd =<< readIVar pv 
     216    array_fetchVal _  _    = return undef 
     217    array_storeVal _ _ _   = retConstError undef 
     218    array_storeElem _ _ _  = retConstError undef 
     219    array_deleteElem _ _   = retConstError undef 
     220 

  • src/Pugs/Types/Code.hs

    r2221 r2441  
    1 {-# OPTIONS_GHC -fglasgow-exts #-} 
    21 
    3 module Pugs.Types.Code where 
     2class (Typeable a) => CodeClass a where 
     3    code_iType :: a -> Type 
     4    code_iType = const $ mkType "Code" 
     5    code_fetch    :: a -> Eval VCode 
     6    code_fetch a = code_assuming a [] [] 
     7    code_store    :: a -> VCode -> Eval () 
     8    code_assuming :: a -> [Exp] -> [Exp] -> Eval VCode 
     9    code_apply    :: a -> Eval Val 
     10    code_assoc    :: a -> VStr 
     11    code_params   :: a -> Params 
    412 
    5 import {-# SOURCE #-} Pugs.AST 
    6 import Pugs.Internals 
    7 import Pugs.Types 
     13instance CodeClass ICode where 
     14    code_iType c  = code_iType . unsafePerformSTM $ readTVar c 
     15    code_fetch    = liftSTM . readTVar 
     16    code_store    = (liftSTM .) . writeTVar 
     17    code_assuming c [] [] = code_fetch c 
     18    code_assuming _ _ _   = undefined 
     19    code_apply    = error "apply" 
     20    code_assoc c  = code_assoc . unsafePerformSTM $ readTVar c 
     21    code_params c = code_params . unsafePerformSTM $ readTVar c 
    822 
    9 class (Typeable a) => Class a where 
    10     iType :: a -> Type 
    11     iType = const $ mkType "Code" 
    12     fetch    :: a -> Eval VCode 
    13     fetch a = assuming a [] [] 
    14     store    :: a -> VCode -> Eval () 
    15     assuming :: a -> [Exp] -> [Exp] -> Eval VCode 
    16     apply    :: a -> Eval Val 
    17     assoc    :: a -> VStr 
    18     params   :: a -> Params 
     23instance CodeClass VCode where 
     24    -- XXX - subType should really just be a mkType itself 
     25    code_iType c  = case subType c of 
     26        SubBlock    -> mkType "Block" 
     27        SubRoutine  -> mkType "Sub" 
     28        SubPrim     -> mkType "Sub" 
     29        SubMethod   -> mkType "Method" 
     30    code_fetch    = return 
     31    code_store _ _= retConstError undef 
     32    code_assuming c [] [] = return c 
     33    code_assuming _ _ _   = error "assuming" 
     34    code_apply    = error "apply" 
     35    code_assoc    = subAssoc 
     36    code_params   = subParams 
     37 

  • src/Pugs/Types/Handle.hs

    r2221 r2441  
    1 {-# OPTIONS_GHC -fglasgow-exts #-} 
    2  
    3 module Pugs.Types.Handle where 
    4  
    5 import {-# SOURCE #-} Pugs.AST 
    6 import Pugs.Internals 
    7 import Pugs.Types 
    81 
    92type Layer = VStr 
    103type FileDescriptor = VInt 
    114 
    12 class (Typeable a) => Class a where 
    13     iType :: a -> Type 
    14     iType = const $ mkType "IO" 
    15     fetch       :: a -> Eval VHandle 
    16     store       :: a -> VHandle -> Eval () 
    17     write       :: a -> VStr -> Eval VInt 
    18     write = error "" 
    19     print       :: a -> [Val] -> Eval VBool 
    20     print gv vals = do 
    21         hdl  <- fetch gv 
     5class (Typeable a) => HandleClass a where 
     6    handle_iType :: a -> Type 
     7    handle_iType = const $ mkType "IO" 
     8    handle_fetch       :: a -> Eval VHandle 
     9    handle_store       :: a -> VHandle -> Eval () 
     10    handle_write       :: a -> VStr -> Eval VInt 
     11    handle_write = error "" 
     12    handle_print       :: a -> [Val] -> Eval VBool 
     13    handle_print gv vals = do 
     14        hdl  <- handle_fetch gv 
    2215        strs <- mapM valToStr vals 
    2316        tryIO False $ do 
    2417            hPutStr hdl $ concatMap encodeUTF8 strs 
    2518            return True 
    26     printf      :: a -> VStr -> [Val] -> Eval VBool 
    27     printf = error "" 
    28     read        :: a -> VInt -> Eval (VInt, VStr) 
    29     read = error "" 
    30     readLine    :: a -> Eval VStr 
    31     readLine = error "" 
    32     getC        :: a -> Eval VStr 
    33     getC = error "" 
    34     close       :: a -> Eval () 
    35     close gv = do 
    36         hdl <- fetch gv 
     19    handle_printf      :: a -> VStr -> [Val] -> Eval VBool 
     20    handle_printf = error "" 
     21    handle_read        :: a -> VInt -> Eval (VInt, VStr) 
     22    handle_read = error "" 
     23    handle_readLine    :: a -> Eval VStr 
     24    handle_readLine = error "" 
     25    handle_getC        :: a -> Eval VStr 
     26    handle_getC = error "" 
     27    handle_close       :: a -> Eval () 
     28    handle_close gv = do 
     29        hdl <- handle_fetch gv 
    3730        liftIO $ hClose hdl 
    38     binmode     :: a -> Layer -> Eval () 
    39     binmode _ _ = return () 
    40     open        :: a -> Layer -> FilePath -> Eval VBool 
    41     open = error "" 
    42     eof         :: a -> Eval VBool 
    43     eof = error "" 
    44     fileNo      :: a -> Eval FileDescriptor 
    45     fileNo = error "" 
    46     seek        :: a -> VInt -> SeekMode -> Eval VBool 
    47     seek = error "" 
    48     tell        :: a -> Eval VInt 
    49     tell = error "" 
     31    handle_binmode     :: a -> Layer -> Eval () 
     32    handle_binmode _ _ = return () 
     33    handle_open        :: a -> Layer -> FilePath -> Eval VBool 
     34    handle_open = error "" 
     35    handle_eof         :: a -> Eval VBool 
     36    handle_eof = error "" 
     37    handle_fileNo      :: a -> Eval FileDescriptor 
     38    handle_fileNo = error "" 
     39    handle_seek        :: a -> VInt -> SeekMode -> Eval VBool 
     40    handle_seek = error "" 
     41    handle_tell        :: a -> Eval VInt 
     42    handle_tell = error "" 
     43 
     44instance HandleClass IHandle where 
     45    handle_fetch = return 
     46    handle_store = error "store" 
     47 

  • 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 

  • src/Pugs/Types/Object.hs

    r2323 r2441  
    1 {-# OPTIONS_GHC -fglasgow-exts #-} 
    21 
    3 module Pugs.Types.Object where 
     2class (Typeable a) => ObjectClass a where 
     3    object_iType :: a -> Type 
    44 
    5 import Pugs.Internals 
    6 import Pugs.Types 
    7  
    8 class (Typeable a) => Class a where 
    9     iType :: a -> Type 
     5instance (Typeable a) => ObjectClass (IVar a) where 
     6    object_iType (IScalar x) = scalar_iType x 
     7    object_iType (IArray x)  = array_iType x 
     8    object_iType (IHash x)   = hash_iType x 
     9    object_iType (ICode x)   = code_iType x 
     10    object_iType (IHandle x) = handle_iType x 
     11    object_iType (IRule x)   = rule_iType x 
     12    object_iType (IThunk x)  = thunk_iType x 
     13    object_iType (IPair x)   = pair_iType x 

  • src/Pugs/Types/Pair.hs

    r2323 r2441  
    1 {-# OPTIONS_GHC -fglasgow-exts #-} 
    21 
    3 module Pugs.Types.Pair where 
     2class (Typeable a) => PairClass a where