Changeset 4986 for src/Pugs/Prim/Match.hs

Timestamp:

06/26/05 10:01:46 (3 years ago)

Author:

autrijus

svk:copy_cache_prev:

6771

Message:

* Repair smart match on types and does calls from the zero

dereference regime by explicitly fetching their metaobjects
and walking the inheritance/mixin tree ourselves.

Files:

• src/Pugs/Prim/Match.hs (modified) (6 diffs)

src/Pugs/Prim/Match.hs

@@ -3 +3 @@
 
 module Pugs.Prim.Match (
-    op2Match, rxSplit, rxSplit_n, matchFromMR
+    op2Match, rxSplit, rxSplit_n, matchFromMR, pkgParents
 ) where
 import Pugs.Internals
@@ -9 +9 @@
 import Pugs.AST
 import Pugs.Types
-import Pugs.Context
 import Pugs.Config
 import qualified RRegex.PCRE as PCRE
@@ -74 +73 @@
 -- XXX - need to generalise this
 op2Match :: Val -> Val -> Eval Val
+
+op2Match x (VRef (MkRef (IScalar sv))) | scalar_iType sv == mkType "Scalar::Const" = do
+    y' <- scalar_fetch' sv
+    op2Match x y'
+
 op2Match x (VRef y) = do
     y' <- readRef y
     op2Match x y'
+
+op2Match x y@(VObject MkObject{ objType = MkType "Class" } ) = do
+    fetch   <- doHash y hash_fetchVal
+    name    <- fromVal =<< fetch "name"
+    op2Match x (VType (MkType name))
 
 op2Match x (VSubst (rx, subst)) | rxGlobal rx = do
@@ -147 +156 @@
 
 op2Match (VType typ) (VType t) = do
-    cls <- asks envClasses
-    return $ VBool (isaType cls (showType t) typ)
+    typs <- pkgParents (showType typ)
+    return . VBool $ showType t `elem` typs
 
 op2Match x y@(VType _) = do
@@ -154 +163 @@
     op2Match (VType typ) y
 
-op2Match x y = op2Cmp (fromVal :: Val -> Eval VStr) (==) x y
+op2Match x y = do
+    op2Cmp (fromVal :: Val -> Eval VStr) (==) x y
 
 op2Cmp :: (a -> Eval b) -> (b -> b -> VBool) -> a -> a -> Eval Val
@@ -195 +205 @@
             rest <- rxSplit_n rx after (n-1)
             return $ (VStr before:matchSubPos match) ++ rest
+
+pkgParents :: VStr -> Eval [VStr]
+pkgParents pkg = do
+    ref     <- readVar (':':'*':pkg)
+    if ref == undef then return [] else do
+    meta    <- readRef =<< fromVal ref
+    fetch   <- doHash meta hash_fetchVal
+    attrs   <- fromVal =<< fetch "traits"
+    pkgs    <- mapM pkgParents attrs
+    return $ nub (pkg:concat pkgs)
+