Changeset 12317 for src/Pugs/AST.hs

Timestamp:

08/16/06 19:28:24 (2 years ago)

Author:

audreyt

Message:

* Glorious refactoring of the Var type.

Previously, Var is type synonym to String, and all package

lookups, OUTER

handling, sigil and twigil parsing etc were done in an extremely adhoc way with String operations.

Now we split Var into several parts.
Take "&Moose::Elk::infix:<antler>" as an example:

v_sigil

VarSigil? -- SScalar

v_twigil

VarTwigil? -- TNone

v_package

Pkg -- ["Moose", "Elk"]

v_categ

VarCateg? -- C_infix

v_name

ID -- "antler"

The names are stored as interned ByteStrings? for fast comparison.

All involved types are changed from String to new types as well,

such as (envPackage

Pkg).

Files:

• src/Pugs/AST.hs (modified) (11 diffs)

src/Pugs/AST.hs

@@ -31 +31 @@
 import Pugs.Types
 import qualified Data.Map as Map
-import Pugs.AST.Internals.Instances
+import qualified Data.Set as Set
+import Pugs.AST.Internals.Instances ()
 import Pugs.AST.Internals
 import Pugs.AST.Prag
@@ -100 +101 @@
 (Is this correct?)
 -}
-genMultiSym :: MonadSTM m => String -> VRef -> m PadMutator
+genMultiSym :: MonadSTM m => Var -> VRef -> m PadMutator
 genMultiSym name ref = do
     --trace ("installing multi: " ++ name) $ return ()
@@ -114 +115 @@
 (right?), shadowing any earlier or outer definition.
 -}
-genSym :: MonadSTM m => String -> VRef -> m PadMutator
-genSym name ref = do
+genSym :: MonadSTM m => Var -> VRef -> m PadMutator
+genSym var ref = do
     --trace ("installing: " ++ name) $ return ()
     tvar    <- liftSTM $ newTVar ref
     fresh   <- liftSTM $ newTVar True
-    return $ \(MkPad map) -> MkPad $ Map.insert name (MkEntry (fresh, tvar)) map
+    return $ \(MkPad map) -> MkPad $ Map.insert var (MkEntry (fresh, tvar)) map
 
 {-|
@@ -131 +132 @@
     Pad _ _ exp     -> isScalarLValue exp
     Sym _ _ exp     -> isScalarLValue exp
-    Var ('$':_)     -> True
+    Var var | SScalar <- v_sigil var -> True
     Syn "${}" _     -> True -- XXX - Change tp App("&prefix:<$>") later
     Syn "$::()" _   -> True
@@ -141 +142 @@
     where
     isSIMPLE x = case unwrap x of
-        App (Var ('&':'p':'r':'e':'f':'i':'x':':':op)) Nothing [y]
-            -> op `elem` coercePrefixOps || (op `elem` simplePrefixOps && isSIMPLE y)
-        App (Var ('&':'p':'r':'e':'f':'i':'x':':':op)) (Just y) []
-            -> op `elem` coercePrefixOps || (op `elem` simplePrefixOps && isSIMPLE y)
-        App (Var ('&':'p':'o':'s':'t':'f':'i':'x':':':op)) Nothing [y]
-            -> op `elem` simplePostfixOps && isSIMPLE y
-        App (Var ('&':'p':'o':'s':'t':'f':'i':'x':':':op)) (Just y) []
-            -> op `elem` simplePostfixOps && isSIMPLE y
-        App (Var ('&':'i':'n':'f':'i':'x':':':op)) Nothing [y, z]
-            -> op `elem` simpleInfixOps && isSIMPLE y && isSIMPLE z
-        App (Var ('&':'i':'n':'f':'i':'x':':':op)) (Just y) [z]
-            -> op `elem` simpleInfixOps && isSIMPLE y && isSIMPLE z
+        App (Var var) Nothing [y]
+            | C_prefix <- v_categ var
+            -> var `Set.member` coercePrefixOps
+                || (var `Set.member` simplePrefixOps && isSIMPLE y)
+            | C_postfix <- v_categ var
+            -> var `Set.member` simplePostfixOps && isSIMPLE y
+        App (Var var) (Just y) []
+            | C_prefix <- v_categ var
+            -> var `Set.member` coercePrefixOps
+                || (var `Set.member` simplePrefixOps && isSIMPLE y)
+            | C_postfix <- v_categ var
+            -> var `Set.member` simplePostfixOps && isSIMPLE y
+        App (Var var) Nothing [x, y]
+            | C_infix <- v_categ var
+            -> var `Set.member` simpleInfixOps && isSIMPLE x && isSIMPLE y
+        App (Var var) (Just x) [y]
+            | C_infix <- v_categ var
+            -> var `Set.member` simpleInfixOps && isSIMPLE x && isSIMPLE y
         _               -> isScalarLValue x
-    coercePrefixOps =
-        [ "!","+","-","~","?","$" ]
-    simplePrefixOps =
-        [ "++","--"
-        , "$","&","+^","~^","?^","\\","^","="
-        ]
-    simplePostfixOps = ["++", "--"]
-    simpleInfixOps =
-        [ "**"
-        , "**="
-        , "*","/","%","x","+&","+<","+>","~&","~<","~>"
-        , "*=","/=","%=","x=","+&=","+<=","+>=","~&=","~<=","~>="
-        , "+","-","~","+|","+^","~|","~^"
-        , "+=","-=","~=","+|=","+^=","~|=","~^="
-        ]
+
+opSet :: VarCateg -> [String] -> Set Var
+opSet cat posts = Set.fromList $ map doMakeVar posts
+    where
+    doMakeVar name = MkVar
+        { v_sigil   = SCode
+        , v_twigil  = TNone
+        , v_package = emptyPkg
+        , v_categ   = cat
+        , v_name    = cast name
+        }
+
+coercePrefixOps, simplePrefixOps, simplePostfixOps, simpleInfixOps :: Set Var
+coercePrefixOps = opSet C_prefix [ "!","+","-","~","?","$" ]
+simplePrefixOps = opSet C_prefix
+    [ "++","--"
+    , "$","&","+^","~^","?^","\\","^","="
+    ]
+simplePostfixOps = opSet C_postfix ["++", "--"]
+simpleInfixOps = opSet C_infix
+    [ "**"
+    , "**="
+    , "*","/","%","x","+&","+<","+>","~&","~<","~>"
+    , "*=","/=","%=","x=","+&=","+<=","+>=","~&=","~<=","~>="
+    , "+","-","~","+|","+^","~|","~^"
+    , "+=","-=","~=","+|=","+^=","~|=","~^="
+    ]
+
+
 
 
@@ -181 +202 @@
     Syn "namespace" [kind, pkg, y]
 mergeStmts x@(Ann ann (Syn syn _)) y | (syn ==) `any` words "subst match //"  =
-    mergeStmts (Ann ann (App (Var "&infix:~~") Nothing [Var "$_", x])) y
+    mergeStmts (Ann ann (App (_Var "&infix:~~") Nothing [_Var "$_", x])) y
 mergeStmts x y@(Ann ann (Syn syn _)) | (syn ==) `any` words "subst match //"  =
-    mergeStmts x (Ann ann (App (Var "&infix:~~") Nothing [Var "$_", y]))
+    mergeStmts x (Ann ann (App (_Var "&infix:~~") Nothing [_Var "$_", y]))
 mergeStmts (Ann ann (Syn "sub" [Val (VCode sub)])) y | subType sub == SubBlock =
     -- bare Block in statement level; annul all its parameters and run it!
@@ -196 +217 @@
 isEmptyParams :: [Param] -> Bool
 isEmptyParams [] = True
-isEmptyParams [x] | [_, '_'] <- paramName x = True
+isEmptyParams [x]
+    | var <- paramName x
+    , _underscore == v_name var
+    , emptyPkg    == v_package var
+    , TNone       == v_twigil var
+    = True
 isEmptyParams _ = False
+
+_underscore :: ID
+_underscore = cast "_" 
 
 newPackage :: String -> String -> [String] -> [String] -> Exp
 newPackage cls name classes roles = Stmts metaObj (newType name)
     where
-    metaObj = Sym SGlobal (':':'*':name) $! Syn ":="
-        [ Var (':':'*':name)
-        , App (Var "&META::new")
+    metaObj = _Sym SGlobal (':':'*':name) $! Syn ":="
+        [ _Var (':':'*':name)
+        , App (_Var "&META::new")
             (Just $ Val (VType $ mkType cls))
             [ Syn "named"
@@ -222 +251 @@
 
 newType :: String -> Exp
-newType name = Sym SGlobal ('&':'&':'*':name) $! Syn ":="
-    [ Var ('&':'*':name)
+newType name = _Sym SGlobal ('&':'&':'*':name) $! Syn ":="
+    [ _Var ('&':'*':name)
     , typeMacro name (Val . VType . mkType $ name)
     ]
 
 newMetaType :: String -> Exp
-newMetaType name = Sym SGlobal ('&':'&':'*':name) $! Syn ":="
-    [ Var ('&':'*':name)
-    , typeMacro name (Var (':':'*':name))
+newMetaType name = _Sym SGlobal ('&':'&':'*':name) $! Syn ":="
+    [ _Var ('&':'*':name)
+    , typeMacro name (_Var (':':'*':name))
     ]
 
@@ -236 +265 @@
 typeMacro name exp = Syn "sub" . (:[]) . Val . VCode $ MkCode
     { isMulti       = True
-    , subName       = name
+    , subName       = cast ('&':name)
     , subEnv        = Nothing
     , subType       = SubMacro
@@ -259 +288 @@
     fmap (MkPad . Map.fromAscList . catMaybes) . mapM checkPrim $ Map.toAscList pad
 
-checkPrim :: (String, PadEntry) -> Eval (Maybe (String, PadEntry))
-checkPrim ((':':'*':_), _) = return Nothing
-checkPrim e@((_, MkEntry (_, tv))) = do
-    rv <- isPrim tv
-    return $ if rv then Nothing else Just e
-checkPrim (key, MkEntryMulti xs) = do
-    xs' <- filterM (fmap not . isPrim . snd) xs
-    return $ if null xs' then Nothing else Just (key, MkEntryMulti xs')
+checkPrim :: (Var, PadEntry) -> Eval (Maybe (Var, PadEntry))
+checkPrim e@(var, entry)
+    | SType <- v_sigil var, isGlobalVar var = return Nothing
+    | MkEntry (_, tv) <- entry = do
+        rv <- isPrim tv
+        return $ if rv then Nothing else Just e
+    | otherwise = do
+        let MkEntryMulti xs = entry
+        xs' <- filterM (fmap not . isPrim . snd) xs
+        return $ if null xs' then Nothing else Just (var, MkEntryMulti xs')
 
 isPrim :: TVar VRef -> Eval Bool
@@ -282 +313 @@
 filterUserDefinedPad (MkPad pad) = MkPad $ Map.filterWithKey doFilter pad
     where
-    doFilter key _ = not (key `elem` reserved)
-    reserved = words $
-        "@*ARGS @*INC %*INC $*PUGS_HAS_HSPLUGINS $*EXECUTABLE_NAME " ++
-        "$*PROGRAM_NAME $*PID $*UID $*EUID $*GID $*EGID @*CHECK @*INIT $*IN " ++
-        "$*OUT $*ERR $*ARGS $/ %*ENV $*CWD @=POD $=POD $?PUGS_VERSION " ++
-        "$*OS &?BLOCK_EXIT %?CONFIG $*_ $*AUTOLOAD"
-
+    doFilter key _ = key `Set.notMember` _reserved
+
+_reserved :: Set Var
+_reserved = Set.fromList . cast . words $
+    "@*ARGS @*INC %*INC $*PUGS_HAS_HSPLUGINS $*EXECUTABLE_NAME " ++
+    "$*PROGRAM_NAME $*PID $*UID $*EUID $*GID $*EGID @*CHECK @*INIT $*IN " ++
+    "$*OUT $*ERR $*ARGS $/ %*ENV $*CWD @=POD $=POD $?PUGS_VERSION " ++
+    "$*OS &?BLOCK_EXIT %?CONFIG $*_ $*AUTOLOAD"