Changeset 3473 for src/Pugs/Prim/List.hs

Show
Ignore:
Timestamp:
05/20/05 00:14:37 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
5016
Message:

* associativity-preserving reduction over left, right

and chain infix operators.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Prim/List.hs

    r3372 r3473  
    11module Pugs.Prim.List ( 
    2     op0Zip, op1Fold, op1Pick, op1Sum, 
     2    op0Zip, op1Pick, op1Sum, 
    33    op2Fold, op2Grep, op2Map, op2Join, 
    44    sortByM, 
    … …  
    2222    zipRest  []     = [] 
    2323    zipRest  (_:xs) = xs 
    24  
    25 op1Fold :: (Val -> Val -> Eval Val) -> Val -> Eval Val 
    26 op1Fold op v = do 
    27     args    <- fromVal v 
    28     case args of 
    29         (a:as)  -> foldM op a as 
    30         _       -> return undef 
    3124 
    3225op1Pick :: Val -> Eval Val 
    … …  
    5851op2Fold sub@(VCode _) list = op2Fold list sub 
    5952op2Fold list sub = do 
     53    code <- fromVal sub 
    6054    args <- fromVal list 
    6155    if null args then return undef else do 
    … …  
    6458        local (\e -> e{ envContext = cxtItemAny }) $ do 
    6559            evl (App (Val sub) [Val x, Val y] []) 
    66     foldM doFold (head args) (tail args) 
     60    case subAssoc code of 
     61        "left"  -> foldM doFold (head args) (tail args) 
     62        "right" -> do 
     63            let args' = reverse args 
     64            foldM (flip doFold) (head args') (tail args') 
     65        "chain" -> callCC $ \esc -> do 
     66            let doFold' x y = do 
     67                val <- doFold x y 
     68                case val of 
     69                    VBool False -> esc val 
     70                    _           -> return val 
     71            foldM doFold' (head args) (tail args) 
     72        _ -> fail $ "Cannot reduce over associativity:" ++ show (subAssoc code) 
    6773 
    6874op2Grep :: Val -> Val -> Eval Val