Changeset 3473

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.

Location:

src/Pugs

Files:

• Eval.hs (modified) (1 diff)
• Prim.hs (modified) (2 diffs)
• Prim/List.hs (modified) (4 diffs)

src/Pugs/Eval.hs

@@ -809 +809 @@
         -- We use the first two elements of invs as invocants, as these are the
         -- types of the op.
-        userdefined_sub <- findSub ("&infix:" ++ op) (take 2 invs) []
-        subbody <- return $ case userdefined_sub of
-            -- If we've found a userdefined sub, we use it.
-            (Just sub) -> Prim $ \_ -> do
-                              list_of_args <- return $ map evaluate invs
-                              list_of_args' <- mapM (\a -> do { z <- a; return z }) list_of_args
-                              op2Fold (VList list_of_args') (VCode sub)
-            -- Else, we use the code as defined in Pugs.Prim
-            _          -> Prim $ f op
+        code <- findSub ("&infix:" ++ op) (take 2 (invs ++ [Val undef, Val undef])) []
+        if isNothing code then return Nothing else do
+        let subBody = const $ do
+                list_of_args    <- mapM evaluate invs
+                op2Fold (VList list_of_args) (VCode $ fromJust code)
         -- Now we construct the sub. Is there a more simple way to do it?
-        code <- return $ mkPrim
-                            { subName     = "&prefix:[" ++ op ++ "]"
-                            , subType     = SubPrim
-                            , subAssoc    = "spre"
-                            , subParams   = params
-                            , subReturns  = mkType "Str"
-                            , subBody     = subbody
-                            }
-        return $ Just code
+        return . Just $ mkPrim
+            { subName     = "&prefix:[" ++ op ++ "]"
+            , subType     = SubPrim
+            , subAssoc    = "spre"
+            , subParams   = params
+            , subReturns  = mkType "Str"
+            , subBody     = Prim subBody
+            }
         where
         -- Taken from Pugs.Prim. Probably this should be refactored. (?)
-        f op     = \[a] -> op1 ("[" ++ op ++ "]") a
         prms'    = map takeWord ["(List)"]
         prms''   = foldr foldParam [] prms'

src/Pugs/Prim.hs

@@ -252 +252 @@
     else return undef
 
-op1 ('[':op) = op1Fold . op2 . init $ op
 op1 "rand"  = \v -> do
     x    <- fromVal v
@@ -1197 +1196 @@
 \\n   Str       left    ~^      (Str, Str)\
 \\n   Str       left    ?|      (Str, Str)\
-\\n   Pair      non     =>      (Any, Any)\
+\\n   Pair      right   =>      (Any, Any)\
 \\n   Int       non     cmp     (Str, Str)\
 \\n   Int       non     <=>     (Num, Num)\

src/Pugs/Prim/List.hs

@@ -1 +1 @@
 module Pugs.Prim.List (
-    op0Zip, op1Fold, op1Pick, op1Sum,
+    op0Zip, op1Pick, op1Sum,
     op2Fold, op2Grep, op2Map, op2Join,
     sortByM,
@@ -22 +22 @@
     zipRest  []     = []
     zipRest  (_:xs) = xs
-
-op1Fold :: (Val -> Val -> Eval Val) -> Val -> Eval Val
-op1Fold op v = do
-    args    <- fromVal v
-    case args of
-        (a:as)  -> foldM op a as
-        _       -> return undef
 
 op1Pick :: Val -> Eval Val
@@ -58 +51 @@
 op2Fold sub@(VCode _) list = op2Fold list sub
 op2Fold list sub = do
+    code <- fromVal sub
     args <- fromVal list
     if null args then return undef else do
@@ -64 +58 @@
         local (\e -> e{ envContext = cxtItemAny }) $ do
             evl (App (Val sub) [Val x, Val y] [])
-    foldM doFold (head args) (tail args)
+    case subAssoc code of
+        "left"  -> foldM doFold (head args) (tail args)
+        "right" -> do
+            let args' = reverse args
+            foldM (flip doFold) (head args') (tail args')
+        "chain" -> callCC $ \esc -> do
+            let doFold' x y = do
+                val <- doFold x y
+                case val of
+                    VBool False -> esc val
+                    _           -> return val
+            foldM doFold' (head args) (tail args)
+        _ -> fail $ "Cannot reduce over associativity:" ++ show (subAssoc code)
 
 op2Grep :: Val -> Val -> Eval Val