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/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