[PUGS] patch - few hyperops

[Markus Laire]

This patch adds these binary-hyperops to pugs: »+« »*« »/« »x« »xx«
This is my first patch ever, so could someone check if this is OK or 
not. This only adds few hyperops, as I'm not 100% sure if this is the 
right way to do it.

Also currently this code emits following warning while compiling:
src/Prim.hs:398:
  Warning: Pattern match(es) are non-exhaustive
           In the definition of `op2Hyper': Patterns not matched: _ _ _
because I'm not sure what op2Hyper should do if it gets invalid types.
First todo-test from t/op/hyper.t passes.
Also these examples now work:
(1,2,3) »x« 3        --> ('111', '222', '333')
(1,2,3) »x« (3,2,1)  --> ('111', '22', '3')
1 »x« (3,2,1)        --> ('111', '11', '1')
(1,2,3) »xx« 3       --> ((1,1,1), (2,2,2), (3,3,3))
(1,2,3) »xx« (3,2,1) --> ((1,1,1), (2,2), (3)
1 »xx« (3,2,1)       --> ((1,1,1), (1,1), (1))
(20,40,60) »/« (2,5,10) --> (10,8,6)
(1,2,3) »+« (10,20,30) »*« (2,3,4)    -->  (21,62,123)
((1,2,3) »+« (10,20,30)) »*« (2,3,4)  -->  (22,66,132)
--
Markus Laire
<Jam. 1:5-6>
Index: src/Prim.hs
===================================================================
--- src/Prim.hs (revision 586)
+++ src/Prim.hs (working copy)
@@ -366,6 +366,8 @@
 op2 "^^" = op2Bool ((/=) :: Bool -> Bool -> Bool)
 op2 "//" = op2Logical isJust
 op2 "!!" = op2Bool (\x y -> not x && not y)
+-- NOTE:  "»" == '\194':'\187'
+op2 ('\194':'\187':op) = op2Hyper $ init $ init $ op
 -- XXX pipe forward XXX
 op2 "and"= op2 "&&"
 op2 "or" = op2 "||"
@@ -392,6 +394,14 @@
        | otherwise = (x:piece, rest') where (piece, rest') = breakOnGlue glue 
xs
 op2 s    = \x y -> return $ VError ("unimplemented binaryOp: " ++ s) (App s [] 
[Val x, Val y])
 
+op2Hyper op x y
+    | VList x' <- x, VList y' <- y
+    = mapM (\(a,b) -> op2 op a b) (x' `zip` y') >>= (return . VList)
+    | VList x' <- x
+    = mapM ((flip (op2 op)) y) x' >>= (return . VList)
+    | VList y' <- y
+    = mapM (op2 op x) y' >>= (return . VList)
+
 op2Push f inv args = do
     let array = vCast inv
         rest = vCast args
@@ -691,6 +701,11 @@
 \\n   Scalar    left    ||      (Bool, Bool)\
 \\n   Scalar    left    ^^      (Bool, Bool)\
 \\n   Scalar    left    //      (Bool, Bool)\
+\\n   List      left    »+«     (Any, Any)\
+\\n   List      left    »*«     (Any, Any)\
+\\n   List      left    »/«     (Any, Any)\
+\\n   List      left    »x«     (Any, Any)\
+\\n   List      left    »xx«    (Any, Any)\
 \\n   List      list    ,       (List)\
 \\n   List      spre    <==     (List)\
 \\n   List      left    ==>     (List, Code)\
Index: src/Parser.hs
===================================================================
--- src/Parser.hs       (revision 586)
+++ src/Parser.hs       (working copy)
@@ -448,8 +448,10 @@
     , postOps  " ++ -- " ++ preOps " ++ -- "            -- Auto-Increment
     , rightOps " ** "                                   -- Exponentiation
     , preOps   " = ! + - ~ ? * ** +^ ~^ ?^ \\ "         -- Symbolic Unary
-    , leftOps  " * / % x xx +& +< +> ~& ~< ~> "         -- Multiplicative
-    , leftOps  " + - ~ +| +^ ~| ~^ "                    -- Additive
+    , leftOps $
+               " »*« »/« »x« »xx« " ++
+               " * / % x xx +& +< +> ~& ~< ~> "         -- Multiplicative
+    , leftOps  " »+« + - ~ +| +^ ~| ~^ "                -- Additive
     , leftOps  " & ! "                                  -- Junctive And
     , leftOps  " ^ | "                                  -- Junctive Or
     , preOps   unary                                    -- Named Unary