Changeset 3388 for src/Pugs/Parser.hs

Timestamp:

05/18/05 16:06:00 (4 years ago)

Author:

iblech

svk:copy_cache_prev:

4977

Message:

User defined infix ops! :)

Files:

• src/Pugs/Parser.hs (modified) (3 diffs)

src/Pugs/Parser.hs

@@ -810 +810 @@
 tightOperators = do
   [optionary, namedUnary, preUnary, postUnary] <- currentUnaryFunctions
+  infixOps <- currentInfixOps
   return $
     [ methOps  " . .+ .? .* .+ .() .[] .{} .<<>> .= "   -- Method postfix
@@ -823 +824 @@
                " >>*<< >>/<< >>x<< >>xx<< >>~<< " ++
                " * / % x xx +& +< +> ~& ~< ~> "         -- Multiplicative
+    , leftOps $ " " ++ unwords infixOps ++ " "          -- User defined ops
+                                                        -- XXX: But they shouldn't
+                                                        -- automatically be leftOps,
+                                                        -- right? --iblech
     , leftOps  " »+« >>+<< + - ~ +| +^ ~| ~^ ?| "       -- Additive
     , listOps  " & "                                    -- Junctive And
@@ -925 +930 @@
     where
     mapPair f (x, y) = (f x, f y)
+
+-- Following code is from a Haskell newbie.
+-- Please check for correctness. --iblech
+currentInfixOps :: RuleParser [String]
+currentInfixOps = do
+    -- We retrieve the list of all current functions
+    funs    <- currentFunctions
+    -- Then we grep for the &infix:... ones.
+    let (infixs, _) = (`partition` funs) $ \x -> case x of
+            ('i':'n':'f':'i':'x':':':_, _, _) -> True
+            _  -> False
+    -- Finally, we return the names of the ops.
+    -- But we've to s/^infix://, as we've to return (say) "+" instead of "infix:+".
+    return $ map extractName infixs
+    where
+    extractName ('i':'n':'f':'i':'x':':':name, _, _) = encodeUTF8 name
+    -- GHC dies with "non exhaustive patterns" if I omit the following line.
+    -- But as we grep above for /^infix:/, we can't possible branch here.
+    extractName _ = error "Should never happen (Parser.hs:currentInfixOps:extractName)"
 
 parseOp :: RuleParser Exp