Changeset 6672

Timestamp:

09/03/05 20:41:00 (3 years ago)

Author:

luqui

Message:

r548@feather: fibonaci | 2005-09-03 20:40:28 +0200
Rewrote findSyms to do real shadowing instead of returning all possible symbols. That is, if
there is a matching name in the lexical, it returns no global names. This solves the lexical
operator bug.

Location:

src/Pugs

Files:

• AST/Internals.hs (modified) (1 diff)
• Eval/Var.hs (modified) (2 diffs)
• Monads.hs (modified) (2 diffs)

src/Pugs/AST/Internals.hs

@@ -4 +4 @@
 module Pugs.AST.Internals (
     Eval,      -- uses Val, Env, SIO
+    EvalMonad,
     Exp(..),   -- uses Pad, Eval, Val
     Env(..),   -- uses Pad, TVar, Exp, Eval, Val

src/Pugs/Eval/Var.hs

@@ -19 +19 @@
 import Pugs.Pretty
 import Pugs.Config
+import Pugs.Monads
 
 findVar :: Var -> Eval (Maybe VRef)
@@ -352 +353 @@
 constSym = return . Just . castV
 
-findSyms :: Var -> Eval [(String, Val)]
+findSyms :: Var -> Eval [(Var, Val)]
 findSyms name = do
-    lex  <- asks envLexical
-    glob <- askGlobal
-    pkg  <- asks envPackage
-    let names = nub [name, toPackage pkg name, toGlobal name]
-    syms <- forM [lex, glob] $ \pad -> do
-        forM names $ \name' -> do
-            case lookupPad name' pad of
-                Just tvar -> do
-                    refs  <- liftSTM $ mapM readTVar tvar
+        runMaybeT (findLexical `mplus` findPackage `mplus` findGlobal) >>= \ret ->
+            case ret of
+                Nothing -> return []
+                Just xs -> return xs
+    where
+        findLexical :: MaybeT EvalMonad [(Var, Val)]
+        findLexical = do
+            lex <- lift $ asks envLexical
+            padSym lex name
+            
+        findPackage :: MaybeT EvalMonad [(Var, Val)]
+        findPackage = do
+            glob <- lift $ askGlobal
+            pkg  <- lift $ asks envPackage
+            padSym glob name `mplus` padSym glob (toPackage pkg name)
+
+        findGlobal :: MaybeT EvalMonad [(Var, Val)]
+        findGlobal = do
+            glob <- lift $ askGlobal
+            padSym glob (toGlobal name)
+
+        padSym :: Pad -> Var -> MaybeT EvalMonad [(Var, Val)]
+        padSym pad var = do
+            case lookupPad var pad of
+                Just tvar -> lift $ do
+                    refs <- liftSTM $ mapM readTVar tvar
                     forM refs $ \ref -> do
                         val <- readRef ref
-                        return (name', val)
-                Nothing -> return []
-    return $ concat (concat syms)
+                        return (var, val)
+                Nothing -> mzero
+        
 
 toGlobal :: String -> String

src/Pugs/Monads.hs

@@ -18 +18 @@
     enterBlock, enterSub,
     evalVal, tempVar,
+    
+    MaybeT, runMaybeT,
 
     module Control.Monad.RWS
@@ -26 +28 @@
 import Pugs.Types
 import Control.Monad.RWS
+
+
+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
+
+instance (Monad m) => Monad (MaybeT m) where
+    (MaybeT mon) >>= f =
+        MaybeT (mon >>= maybe (return Nothing) (runMaybeT . f))
+    return              = MaybeT . return . Just
+
+instance MonadTrans MaybeT where
+    lift mon = MaybeT (mon >>= return . Just)
+
+instance (Monad m) => MonadPlus (MaybeT m) where
+    mzero                       = MaybeT (return Nothing)
+    mplus (MaybeT a) (MaybeT b) = MaybeT $ do
+        ma <- a
+        mb <- b
+        return $ ma `mplus` mb
+
 
 {-|