Changeset 12317 for src/Pugs/Eval

Show
Ignore:
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:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Eval/Var.hs

    r12208 r12317  
    44    findVar, findVarRef, 
    55    findSub, inferExpType,  inferExpCxt, FindSubFailure(..), 
    6     isQualified, packageOf, qualify, 
    7     toPackage, toQualified, 
     6    packageOf, toPackage, toQualified, 
    87) where 
    98import qualified Data.Map as Map 
    … …  
    2019import qualified Pugs.Val as Val 
    2120import Pugs.Val hiding (Val, IValue, VUndef) 
     21import qualified Data.ByteString.Char8 as Str 
    2222 
    2323findVar :: Var -> Eval (Maybe VRef) 
    24 findVar (':':x:_) | x /= '*' = return Nothing 
    25 findVar name = do 
    26     rv <- findVarRef name 
    27     case rv of 
    28         Nothing  -> case name of 
    29             ('&':_) -> do 
    30                 sub <- findSub name Nothing [] 
    31                 return $ either (const Nothing) (Just . codeRef) sub 
    32             _ -> return Nothing 
    33         Just ref -> fmap Just $ liftSTM (readTVar ref) 
     24findVar var 
     25    | SType <- v_sigil var 
     26    , not (isGlobalVar var) 
     27    = return Nothing 
     28    | otherwise = do 
     29        rv <- findVarRef var 
     30        case rv of 
     31            Just ref -> fmap Just $ liftSTM (readTVar ref) 
     32            Nothing 
     33                | SCode == v_sigil var || SCodeMulti == v_sigil var -> do 
     34                    sub <- findSub var Nothing [] 
     35                    return $ either (const Nothing) (Just . codeRef) sub 
     36                | otherwise -> return Nothing 
     37 
     38 
     39lookupShellEnvironment :: ByteString -> Eval (Maybe (TVar VRef)) 
     40lookupShellEnvironment name = do 
     41    exists <- evalExp $ App (_Var "&exists") (Just (_Var "%*ENV")) [Val (VStr $ cast name)] 
     42    case exists of 
     43        VBool False -> do 
     44            retError "no such ENV variable" name 
     45        _           -> do 
     46            rv   <- enterLValue (evalExp $ Syn "{}" [_Var "%*ENV", Val (VStr $ cast name)]) 
     47            tvar <- liftSTM . newTVar =<< fromVal rv 
     48            return (Just tvar) 
    3449 
    3550findVarRef :: Var -> Eval (Maybe (TVar VRef)) 
    36 findVarRef name 
    37     | Just (package, name') <- breakOnGlue "::" name 
    38     = case () of 
    39         _ | Just (sig, "") <- breakOnGlue "CALLER" package -> do 
    40             maybeCaller <- asks envCaller 
    41             case maybeCaller of 
    42                 Just env -> local (const env) $ do 
    43                     rv <- findVarRef (sig ++ name') 
    44                     return rv 
    45                 Nothing -> retError "cannot access CALLER:: in top level" name 
    46         _ | Just (sig, "") <- breakOnGlue "ENV" package -> fix $ \upLevel -> do 
    47             maybeCaller <- asks envCaller 
    48             case maybeCaller of 
    49                 Just env -> local (const env) $ do 
    50                     rv <- findVarRef (sig ++ name') 
    51                     if isJust rv then return rv else upLevel 
    52                 Nothing -> do 
    53                     -- final callback: try an "environment" lookup 
    54                     -- XXX: how does "@+PATH" differ from "$+PATH"? 
    55                     -- XXX: how to tell empty env from nonexistent env? 
    56                     --      should we allow writes? 
    57                     exists <- evalExp $ App (Var "&exists") (Just (Var "%*ENV")) [Val (VStr name')] 
    58                     case exists of 
    59                         VBool False -> do 
    60                             retError "no such ENV:: variable" name' 
    61                         _           -> do 
    62                             rv   <- enterLValue (evalExp $ Syn "{}" [Var "%*ENV", Val (VStr name')]) 
    63                             tvar <- liftSTM . newTVar =<< fromVal rv 
    64                             return (Just tvar) 
    65         _ | Just (sig, "") <- breakOnGlue "OUTER" package -> do 
    66             maybeOuter <- asks envOuter 
    67             case maybeOuter of 
    68                 Just env -> local (const env) $ do 
    69                     findVarRef (sig ++ name') 
    70                 Nothing -> retError "cannot access OUTER:: in top level" name 
    71         _ -> doFindVarRef name 
    72     | (sig:'+':name') <- name = findVarRef (sig:("ENV::"++name')) 
    73     | (_:'?':_) <- name = do 
    74         rv  <- getMagical name 
     51findVarRef var@MkVar{ v_sigil = sig, v_twigil = twi, v_name = name, v_package = pkg } 
     52    | Just var' <- dropVarPkg (__"CALLER") var = do 
     53        maybeCaller <- asks envCaller 
     54        case maybeCaller of 
     55            Just env -> local (const env) $ findVarRef var' 
     56            Nothing -> retError "cannot access CALLER:: in top level" var 
     57 
     58    | Just var' <- dropVarPkg (__"ENV") var = fix $ \upLevel -> do 
     59        maybeCaller <- asks envCaller 
     60        case maybeCaller of 
     61            Just env -> local (const env) $ do 
     62                rv <- findVarRef var' 
     63                if isJust rv then return rv else upLevel 
     64            -- final callback: try an "environment" lookup 
     65            -- XXX: how does "@+PATH" differ from "$+PATH"? 
     66            -- XXX: how to tell empty env from nonexistent env? 
     67            --      should we allow writes? 
     68            Nothing -> lookupShellEnvironment (cast name) 
     69 
     70    | Just var' <- dropVarPkg (__"OUTER") var = do 
     71        maybeOuter <- asks envOuter 
     72        case maybeOuter of 
     73            Just env -> local (const env) $ findVarRef var' 
     74            Nothing -> retError "cannot access OUTER:: in top level" name 
     75 
     76    | pkg /= emptyPkg = doFindVarRef var 
     77 
     78    | TMagical <- twi = do 
     79        rv  <- getMagical var 
    7580        case rv of 
    76             Nothing  -> doFindVarRef name 
     81            Nothing  -> doFindVarRef var 
    7782            Just val -> do 
    7883                tvar <- liftSTM $ newTVar (MkRef . constScalar $ val) 
    7984                return $ Just tvar 
    80     | "%" <- name = do 
     85 
     86    | SHash <- sig, nullID == name = do 
    8187        {- %CALLER::, %OUTER::, %Package::, etc, all recurse to here. -} 
    8288        pad <- asks envLexical 
    … …  
    8793        tvar <- liftSTM $ newTVar hashref 
    8894        return $ Just tvar 
    89     | otherwise = doFindVarRef name 
     95    | otherwise = doFindVarRef var 
    9096    where 
    9197    padEntryToHashEntry :: (Var, [(TVar Bool, TVar VRef)]) -> Eval (VStr, Val) 
    … …  
    9399        vref   <- liftSTM (readTVar tvref) 
    94100        let val = VRef vref 
    95         return (key, val) 
    96     padEntryToHashEntry (_, []) = do fail "Nonexistant var in pad?" 
    97     doFindVarRef :: Var -> Eval (Maybe (TVar VRef)) 
    98     doFindVarRef name = do 
    99         callCC $ \foundIt -> do 
    100             lexSym  <- fmap (findSym name . envLexical) ask 
    101             when (isJust lexSym) $ foundIt lexSym 
    102             glob    <- liftSTM . readTVar . envGlobal =<< ask 
    103             name'   <- toQualified name 
    104             -- XXX - find qualified name here 
    105             let globSym = findSym name' glob 
    106             when (isJust globSym) $ foundIt globSym 
    107             let globSym = findSym (toGlobal name) glob 
    108             when (isJust globSym) $ foundIt globSym 
    109             return Nothing 
     101        return (cast key, val) 
     102    padEntryToHashEntry (_, []) = fail "Nonexistant var in pad?" 
     103 
     104doFindVarRef :: Var -> Eval (Maybe (TVar VRef)) 
     105doFindVarRef var = do 
     106    callCC $ \foundIt -> do 
     107        lexSym  <- fmap (findSym var . envLexical) ask 
     108        when (isJust lexSym) $ foundIt lexSym 
     109        -- XXX - this is bogus; we should not fallback if it's not in lex csope. 
     110        glob    <- liftSTM . readTVar . envGlobal =<< ask 
     111        var'    <- toQualified var 
     112        let globSym = findSym var' glob 
     113        when (isJust globSym) $ foundIt globSym 
     114        -- XXX - ditto for globals 
     115        let globSym = findSym (toGlobalVar var) glob 
     116        when (isJust globSym) $ foundIt globSym 
     117        return Nothing 
    110118 
    111119 
    … …  
    143151    | NoSuchMethod !Type 
    144152 
    145 findSub :: String     -- ^ Name, with leading @\&@. 
     153_SUPER :: ByteString 
     154_SUPER = __"SUPER" 
     155 
     156findSub :: Var        -- ^ Name, with leading @\&@. 
    146157        -> Maybe Exp  -- ^ Invocant 
    147158        -> [Exp]      -- ^ Other arguments 
    148159        -> Eval (Either FindSubFailure VCode) 
    149 findSub name' invs args = do 
    150     case invs of 
    151         Just _ | Just (package, name') <- breakOnGlue "::" name 
    152                , Just (sig, "") <- breakOnGlue "SUPER" package -> do 
    153             typ <- asks envPackage 
    154             findSuperSub (mkType typ) (sig ++ name') 
    155         Just exp | not (':' `elem` drop 2 name) -> case unwrap exp of 
    156             Val inv@VV{}     -> withExternalCall callMethodVV inv  
    157             Val inv@PerlSV{} -> withExternalCall callMethodPerl5 inv  
    158             exp' -> do 
    159                 typ <- evalInvType exp' 
    160                 findTypedSub typ name 
    161         _ -> findBuiltinSub NoSuchSub name 
    162  
     160findSub var invs args 
     161    | Nothing <- invs = findBuiltinSub NoSuchSub var 
     162    | not (isQualifiedVar var) = case unwrap inv of 
     163        Val inv@VV{}     -> withExternalCall callMethodVV inv  
     164        Val inv@PerlSV{} -> withExternalCall callMethodPerl5 inv  
     165        inv' -> do 
     166            typ <- evalInvType inv' 
     167            findTypedSub (cast typ) var 
     168    | Just var' <- dropVarPkg _SUPER var = do 
     169        pkg <- asks envPackage 
     170        findSuperSub pkg var' 
     171    | otherwise = do 
     172        findBuiltinSub NoSuchSub var 
    163173    where 
    164     err :: b -> Maybe a -> Either b a 
    165     err _ (Just j) = Right j 
    166     err x Nothing  = Left x 
    167  
    168     name = possiblyFixOperatorName name' 
    169  
    170     findSuperSub :: Type -> String -> Eval (Either FindSubFailure VCode) 
    171     findSuperSub typ name = do 
    172         let pkg = showType typ 
    173             qualified = (head name:pkg) ++ "::" ++ tail name 
    174         subs    <- findWithSuper pkg name 
    175         subs'   <- either (flip findBuiltinSub name) (return . Right) subs 
     174    inv = fromJust invs 
     175 
     176    findSuperSub :: Pkg -> Var -> Eval (Either FindSubFailure VCode) 
     177    findSuperSub pkg var = do 
     178--          qualified = Str.concat [Str.take 1 name, pkg, __"::", Str.tail name] 
     179        subs    <- findWithSuper pkg var 
     180        subs'   <- either (flip findBuiltinSub var) (return . Right) subs 
    176181        case subs' of 
    177             Right sub | subName sub == qualified -> return (Left $ NoSuchMethod typ) 
     182--          Right sub | subName sub == qualified -> return (Left $ NoSuchMethod typ) 
    178183            _   -> return subs' 
    179     findTypedSub :: Type -> String -> Eval (Either FindSubFailure VCode) 
    180     findTypedSub typ name = do 
    181         subs    <- findWithPkg (showType typ) name 
    182         either (flip findBuiltinSub name) (return . Right) subs 
    183     findBuiltinSub :: FindSubFailure -> String -> Eval (Either FindSubFailure VCode) 
    184     findBuiltinSub failure name = do 
    185         sub <- findSub' name 
    186         maybe (fmap (err failure) $ possiblyBuildMetaopVCode name) (return . Right) sub 
     184    findTypedSub :: Pkg -> Var -> Eval (Either FindSubFailure VCode) 
     185    findTypedSub pkg var = do 
     186        subs    <- findWithPkg pkg var 
     187        either (flip findBuiltinSub var) (return . Right) subs 
     188    findBuiltinSub :: FindSubFailure -> Var -> Eval (Either FindSubFailure VCode) 
     189    findBuiltinSub failure var = do 
     190        sub <- findSub' var 
     191        maybe (fmap (err failure) $ possiblyBuildMetaopVCode var) (return . Right) sub 
    187192    evalInvType :: Exp -> Eval Type 
    188193    evalInvType x = inferExpType $ unwrap x 
    … …  
    190195    withExternalCall callMeth inv = do 
    191196        fmap (err . NoSuchMethod $ valType inv) $ do 
    192             metaSub <- possiblyBuildMetaopVCode name 
     197            metaSub <- possiblyBuildMetaopVCode var 
    193198            if isJust metaSub then return metaSub else callMeth 
    194199 
    195200    callMethodVV :: Eval (Maybe VCode) 
    196201    callMethodVV = do 
    197         let (_, methName) = breakSigil name 
     202        let methName = cast (v_name var) 
    198203        -- Look up the proto for the method in VV land right here 
    199204        -- Whether it matched or not, it's the proto's signature 
    … …  
    224229    callMethodPerl5 = do 
    225230        return . Just $ mkPrim 
    226             { subName     = name 
     231            { subName     = cast (v_name var) 
    227232            , subParams   = makeParams ["Object", "List", "Named"] 
    228233            , subReturns  = mkType "Scalar::Perl5" 
    … …  
    232237                namSVs  <- fmap concat (fromVals named) 
    233238                let svs = posSVs ++ namSVs 
    234                 found   <- liftIO $ canPerl5 sv (tail name) 
     239                found   <- liftIO $ canPerl5 sv (cast $ v_name var) 
    235240                found'  <- liftIO $ if found 
    236241                    then return found 
    237                     else canPerl5 sv "AUTOLOAD" 
     242                    else canPerl5 sv (__"AUTOLOAD") 
    238243                if not found' 
    239244                    then do 
    240245                        -- XXX - when svs is empty, this could call back here infinitely 
    241246                        --       add an extra '&' to force no-reinterpretation. 
    242                         evalExp (App (Var ('&':name)) Nothing (map (Val . PerlSV) (sv:svs))) 
     247                        evalExp $ 
     248                            App (Var var{ v_sigil = SCodeMulti }) Nothing 
     249                                (map (Val . PerlSV) (sv:svs)) 
    243250                    else do 
    244                         subSV   <- liftIO . vstrToSV $ tail name 
     251                        subSV   <- liftIO . bufToSV . cast $ v_name var 
    245252                        runInvokePerl5 subSV sv svs 
    246253            } 
    247     possiblyBuildMetaopVCode :: String -> Eval (Maybe VCode) 
    248     possiblyBuildMetaopVCode op'' | "&prefix:[" `isPrefixOf` op'', "]" `isSuffixOf` op'' = do  
    249         -- Strip the trailing "]" from op 
    250         let op' = drop 9 (init op'') 
    251         let (op, keep) | '\\':real <- op' = (real, True) 
    252                        | otherwise        = (op', False) 
    253         -- We try to find the userdefined sub. 
    254         -- We use the first two elements of invs as invocants, as these are the 
    255         -- types of the op. 
    256             rv = fmap (either (const Nothing) Just) $ findSub ("&infix:" ++ op) Nothing (take 2 $ args ++ [Val undef, Val undef]) 
    257         maybeM rv $ \code -> return $ mkPrim 
    258             { subName     = "&prefix:[" ++ (if keep then "\\" else "") ++ op ++ "]" 
    259             , subType     = SubPrim 
    260             , subAssoc    = "spre" 
    261             , subParams   = makeParams $ 
    262                 if any isLValue (subParams code) 
    263                     then ["rw!List"] -- XXX - does not yet work for the [=] case 
    264                     else ["List"] 
    265             , subReturns  = anyType 
    266             , subBody     = Prim $ \[vs] -> do 
    267                 list_of_args <- fromVal vs 
    268                 op2Reduce keep list_of_args (VCode code) 
    269             } 
    270         -- Now we construct the sub. Is there a more simple way to do it? 
    271     possiblyBuildMetaopVCode op' | "&prefix:" `isPrefixOf` op', "\171" `isSuffixOf` op' = do  
    272         let op = drop 8 (init op') 
    273         possiblyBuildMetaopVCode ("&prefix:" ++ op ++ "<<") 
    274     possiblyBuildMetaopVCode op' | "&prefix:" `isPrefixOf` op', "<<" `isSuffixOf` op' = do  
    275         let op = drop 8 (init (init op')) 
    276             rv = fmap (either (const Nothing) Just) $ findSub ("&prefix:" ++ op) Nothing [head $ args ++ [Val undef]] 
    277         maybeM rv $ \code -> return $ mkPrim 
    278             { subName     = "&prefix:" ++ op ++ "<<" 
    279             , subType     = SubPrim 
    280             , subAssoc    = subAssoc code 
    281             , subParams   = subParams code 
    282             , subReturns  = mkType "List" 
    283             , subBody     = Prim 
    284                 (\x -> op1HyperPrefix code (listArg x)) 
    285             } 
    286     possiblyBuildMetaopVCode op' | "&postfix:\187" `isPrefixOf` op' = do 
    287         let op = drop 10 op' 
    288         possiblyBuildMetaopVCode ("&postfix:>>" ++ op) 
    289     possiblyBuildMetaopVCode op' | "&postfix:>>" `isPrefixOf` op' = do 
    290         let op = drop 11 op' 
    291             rv = fmap (either (const Nothing) Just) $ findSub ("&postfix:" ++ op) Nothing [head $ args ++ [Val undef]] 
    292         maybeM rv $ \code -> return $ mkPrim 
    293             { subName     = "&postfix:>>" ++ op 
    294             , subType     = SubPrim 
    295             , subAssoc    = subAssoc code 
    296             , subParams   = subParams code 
    297             , subReturns  = mkType "List" 
    298             , subBody     = Prim 
    299                 (\x -> op1HyperPostfix code (listArg x)) 
    300             } 
    301     possiblyBuildMetaopVCode op' | "&infix:\187" `isPrefixOf` op', "\171" `isSuffixOf` op' = do  
    302         let op = drop 8 (init op') 
    303         possiblyBuildMetaopVCode ("&infix:>>" ++ op ++ "<<") 
    304     possiblyBuildMetaopVCode op' | "&infix:>>" `isPrefixOf` op', "<<" `isSuffixOf` op' = do  
    305         let op = drop 9 (init (init op')) 
    306             rv = fmap (either (const Nothing) Just) $ findSub ("&infix:" ++ op) Nothing (take 2 (args ++ [Val undef, Val undef])) 
    307         maybeM rv $ \code -> return $ mkPrim 
    308             { subName     = "&infix:>>" ++ op ++ "<<" 
    309             , subType     = SubPrim 
    310             , subAssoc    = subAssoc code 
    311             , subParams   = makeParams ["Any", "Any"] 
    312             , subReturns  = mkType "List" 
    313             , subBody     = Prim (\[x, y] -> op2Hyper code x y) 
    314             } 
    315         -- Taken from Pugs.Prim. Probably this should be refactored. (?) 
    316     possiblyBuildMetaopVCode _ = return Nothing 
    317     listArg [x] = x 
    318     listArg xs = VList xs 
    319     makeParams = map (\p -> p{ isWritable = isLValue p }) . foldr foldParam [] . map takeWord 
    320     takeWord = takeWhile isWord . dropWhile (not . isWord) 
    321     isWord   = not . (`elem` "(),:") 
    322     findAttrs pkg = do 
    323         maybeM (findVar (':':'*':pkg)) $ \ref -> do 
    324             meta    <- readRef ref 
    325             fetch   <- doHash meta hash_fetchVal 
    326             fromVal =<< fetch "is" 
    327     findWithPkg :: String -> String -> Eval (Either FindSubFailure VCode) 
    328     findWithPkg pkg name = do 
    329         subs <- findSub' (('&':pkg) ++ "::" ++ tail name) 
    330         maybe (findWithSuper pkg name) (return . Right) subs 
    331     findWithSuper :: String -> String -> Eval (Either FindSubFailure VCode) 
    332     findWithSuper pkg name = do 
     254 
     255    findWithPkg :: Pkg -> Var -> Eval (Either FindSubFailure VCode) 
     256    findWithPkg pkg var = do 
     257        subs <- findSub' var{ v_package = pkg } 
     258        maybe (findWithSuper pkg var) (return . Right) subs 
     259 
     260    findWithSuper :: Pkg -> Var -> Eval (Either FindSubFailure VCode) 
     261    findWithSuper pkg var = do 
    333262        -- get superclasses 
    334263        attrs <- fmap (fmap (filter (/= pkg) . nub)) $ findAttrs pkg 
    335         if isNothing attrs || null (fromJust attrs) then fmap (err NoMatchingMulti) (findSub' name) else do 
     264        if isNothing attrs || null (fromJust attrs) then fmap (err NoMatchingMulti) (findSub' var) else do 
    336265        (`fix` (fromJust attrs)) $ \run pkgs -> do 
    337             if null pkgs then return (Left $ NoSuchMethod $ mkType pkg) else do 
    338             subs <- findWithPkg (head pkgs) name 
     266            if null pkgs then return (Left $ NoSuchMethod (cast pkg)) else do 
     267            subs <- findWithPkg (head pkgs) var 
    339268            either (const $ run (tail pkgs)) (return . Right) subs 
    340     findSub' :: String -> Eval (Maybe VCode) 
    341     findSub' name = do 
    342         subSyms     <- findSyms name 
     269    findSub' :: Var -> Eval (Maybe VCode) 
     270    findSub' var = do 
     271        subSyms     <- findSyms var 
    343272        lens        <- mapM argSlurpLen (unwrap $ maybeToList invs ++ args) 
    344273        doFindSub (sum lens) subSyms 
    … …  
    357286    valSlurpLen _  = return 1 -- XXX 
    358287 
    359     doFindSub :: Int -> [(String, Val)] -> Eval (Maybe VCode) 
     288    doFindSub :: Int -> [(Var, Val)] -> Eval (Maybe VCode) 
    360289    doFindSub slurpLen subSyms = do 
    361290        subs' <- subs slurpLen subSyms 
    … …  
    365294            ((_, sub):_)    -> Just sub 
    366295            _               -> Nothing 
    367     subs :: Int -> [(String, Val)] -> Eval [((Bool, Bool, Int, Int), VCode)] 
     296    subs :: Int -> [(Var, Val)] -> Eval [((Bool, Bool, Int, Int), VCode)] 
    368297    subs slurpLen subSyms = fmap catMaybes . forM subSyms $ \(_, val) -> do 
    369298        sub@(MkCode{ subReturns = ret, subParams = prms }) <- fromVal val 
    … …  
    377306            let bound = either (const False) (const True) $ bindParams sub invs args 
    378307            return ((isMulti sub, bound, sum deltaArgs, deltaCxt), fun) 
    379     deltaFromCxt :: Type -> Eval Int 
    380     deltaFromCxt x  = do 
    381         cls <- asks envClasses 
    382         cxt <- asks envContext 
    383         return $ deltaType cls (typeOfCxt cxt) x 
    384     deltaFromPair (x, y) = do 
    385         cls <- asks envClasses 
    386         typ <- inferExpType y 
    387         return $ deltaType cls x typ 
     308 
     309    firstArg = [maybe (Val undef) id (listToMaybe args)] 
     310 
     311    buildPrefixHyper name var = do 
     312        let rv = fmap (either (const Nothing) Just) $ 
     313                findSub var Nothing firstArg 
     314        maybeM rv $ \code -> return $ mkPrim 
     315            { subName     = name 
     316            , subType     = SubPrim 
     317            , subAssoc    = subAssoc code 
     318            , subParams   = subParams code 
     319            , subReturns  = mkType "List" 
     320            , subBody     = Prim 
     321                (\x -> op1HyperPrefix code (listArg x)) 
     322            } 
     323 
     324    buildPostfixHyper name var = do 
     325        let rv = fmap (either (const Nothing) Just) $ 
     326                findSub var Nothing firstArg 
     327        maybeM rv $ \code -> return $ mkPrim 
     328            { subName     = name 
     329            , subType     = SubPrim 
     330            , subAssoc    = subAssoc code 
     331            , subParams   = subParams code 
     332            , subReturns  = mkType "List" 
     333            , subBody     = Prim 
     334                (\x -> op1HyperPostfix code (listArg x)) 
     335            } 
     336 
     337    buildInfixHyper name var = do 
     338        let rv = fmap (either (const Nothing) Just) $ 
     339                findSub var Nothing (take 2 (args ++ [Val undef, Val undef])) 
     340        maybeM rv $ \code -> return $ mkPrim 
     341            { subName     = name 
     342            , subType     = SubPrim 
     343            , subAssoc    = subAssoc code 
     344            , subParams   = makeParams ["Any", "Any"] 
     345            , subReturns  = mkType "List" 
     346            , subBody     = Prim (\[x, y] -> op2Hyper code x y) 
     347            } 
     348 
     349    possiblyBuildMetaopVCode :: Var -> Eval (Maybe VCode) 
     350    possiblyBuildMetaopVCode var@MkVar{ v_categ = cat, v_name = name } 
     351        | C_prefix <- cat, '\171' <- Str.last buf = do 
     352            buildPrefixHyper buf var{ v_name = cast $ Str.init buf } 
     353        | C_prefix <- cat, __"<<" `Str.isSuffixOf` buf = do 
     354            buildPrefixHyper buf var{ v_name = cast $ dropEnd 2 buf } 
     355        | C_postfix <- cat, '\187' <- Str.head buf = do 
     356            buildPostfixHyper buf var{ v_name = cast $ Str.tail buf } 
     357        | C_postfix <- cat, __">>" `Str.isPrefixOf` buf = do 
     358            buildPostfixHyper buf var{ v_name = cast $ Str.drop 2 buf } 
     359        | C_infix <- cat, '\187' <- Str.head buf, '\171' <- Str.last buf = do 
     360            buildInfixHyper buf var{ v_name = cast $ Str.init (Str.tail buf) } 
     361        | C_infix <- cat, __">>" `Str.isPrefixOf` buf, __"<<" `Str.isSuffixOf` buf = do 
     362            buildInfixHyper buf var{ v_name = cast $ Str.take 2 (dropEnd 2 buf) } 
     363        | C_prefix <- cat, '[' <- Str.head buf, ']' <- Str.last buf = do 
     364            -- Strip the trailing "]" from op 
     365            let (op, keep) 
     366                    | Str.index buf 1 == '\\'   = (Str.drop 2 (Str.init buf), True) 
     367                    | otherwise                 = (Str.tail (Str.init buf), False) 
     368 
     369            -- We try to find the userdefined sub. 
     370            -- We use the first two elements of invs as invocants, as these are the 
     371            -- types of the op. 
     372                rv = fmap (either (const Nothing) Just) $ 
     373                    findSub (var{ v_categ = C_infix, v_name = cast op }) Nothing 
     374                        (take 2 $ args ++ [Val undef, Val undef]) 
     375            maybeM rv $ \code -> return $ mkPrim 
     376                { subName     = buf 
     377                , subType     = SubPrim 
     378                , subAssoc    = "spre" 
     379                , subParams   = makeParams $ 
     380                    if any isLValue (subParams code) 
     381                        then ["rw!List"] -- XXX - does not yet work for the [=] case 
     382                        else ["List"] 
     383                , subReturns  = anyType 
     384                , subBody     = Prim $ \[vs] -> do 
     385                    list_of_args <- fromVal vs 
     386                    op2Reduce keep list_of_args (VCode code) 
     387                } 
     388            -- Now we construct the sub. Is there a more simple way to do it? 
     389        | otherwise = return Nothing 
     390        where 
     391        buf = cast name 
     392 
     393metaVar :: Pkg -> Var 
     394-- metaVar = MkVar SType TNone globalPkg CNone . cast 
     395metaVar pkg = MkVar 
     396    { v_sigil   = SType 
     397    , v_twigil  = TGlobal 
     398    , v_package = emptyPkg 
     399    , v_categ   = CNone 
     400    , v_name    = cast pkg 
     401    } 
     402 
     403err :: b -> Maybe a -> Either b a 
     404err _ (Just j) = Right j 
     405err x Nothing  = Left x 
     406 
     407listArg :: [Val] -> Val 
     408listArg [x] = x 
     409listArg xs = VList xs 
     410 
     411makeParams :: [String] -> [Param] 
     412makeParams = map (\p -> p{ isWritable = isLValue p }) . foldr foldParam [] . map takeWord 
     413    where 
     414    takeWord = takeWhile isWord . dropWhile (not . isWord) 
     415    isWord   = not . (`elem` "(),:") 
     416 
     417deltaFromCxt :: Type -> Eval Int 
     418deltaFromCxt x  = do 
     419    cls <- asks envClasses 
     420    cxt <- asks envContext 
     421    return $ deltaType cls (typeOfCxt cxt) x 
     422 
     423deltaFromPair :: (Type, Exp) -> Eval Int 
     424deltaFromPair (x, y) = do 
     425    cls <- asks envClasses 
     426    typ <- inferExpType y 
     427    return $ deltaType cls x typ 
     428 
     429findAttrs pkg = do 
     430    maybeM (findVar $ metaVar pkg) $ \ref -> do 
     431        meta    <- readRef ref 
     432        fetch   <- doHash meta hash_fetchVal 
     433        fmap (map (cast :: String -> Pkg)) (fromVal =<< fetch "is") 
    388434 
    389435{-| 
    … …  
    392438-} 
    393439inferExpType :: Exp -> Eval Type 
    394 inferExpType exp@(Var (_:'.':_)) = fromVal =<< evalExp exp 
    395 inferExpType exp@(Var (_:'!':_:_)) = fromVal =<< evalExp exp 
    396 inferExpType (Var var) = do 
    397     rv  <- findVar var 
    398     case rv of 
    399         Nothing  -> return $ typeOfSigil (head var) 
    400         Just ref -> do 
    401             let typ = refType ref 
    402             cls <- asks envClasses 
    403             if isaType cls "List" typ 
    404                 then return typ 
    405                 else fromVal =<< readRef ref 
     440inferExpType exp@(Var var) 
     441    | TAttribute <- v_twigil var = fromVal =<< evalExp exp 
     442    | TPrivate <- v_twigil var   = fromVal =<< evalExp exp 
     443    | otherwise = do 
     444        rv  <- findVar var 
     445        case rv of 
     446            Nothing  -> return $ typeOfSigilVar var 
     447            Just ref -> do 
     448                let typ = refType ref 
     449                cls <- asks envClasses 
     450                if isaType cls "List" typ 
     451                    then return typ 
     452                    else fromVal =<< readRef ref 
    406453inferExpType (Val val) = fromVal val 
    407454inferExpType (App (Val val) _ _) = do 
    408455    sub <- fromVal val 
    409456    return $ subReturns sub 
    410 inferExpType (App (Var "&new") (Just inv) _) = inferExpType $ unwrap inv 
     457inferExpType (App (Var var) (Just inv) _) 
     458    | var == cast "&new" 
     459    = inferExpType $ unwrap inv 
    411460inferExpType (App (Var name) invs args) = do 
    412461    sub <- findSub name invs args 
    … …  
    488537@Nothing@ if the name does not match a known magical. 
    489538-} 
    490 getMagical :: String -- ^ Name of the magical var to evaluate 
     539getMagical :: Var -- ^ Name of the magical var to evaluate 
    491540           -> Eval (Maybe Val) 
    492 getMagical "$?FILE"     = posSym posName 
    493 getMagical "$?LINE"     = posSym posBeginLine 
    494 getMagical "$?COLUMN"   = posSym posBeginColumn 
    495 getMagical "$?POSITION" = posSym pretty 
    496 getMagical "$?MODULE"   = constSym "main" 
    497 getMagical "$?OS"       = constSym $ getConfig "osname" 
    498 getMagical "$?CLASS"    = fmap (Just . VType . mkType) (asks envPackage) 
    499 getMagical ":?CLASS"    = fmap (Just . VType . mkType) (asks envPackage) 
    500 getMagical "$?PACKAGE"  = fmap (Just . VType . mkType) (asks envPackage) 
    501 getMagical ":?PACKAGE"  = fmap (Just . VType . mkType) (asks envPackage) 
    502 getMagical "$?ROLE"     = fmap (Just . VType . mkType) (asks envPackage) 
    503 getMagical ":?ROLE"     = fmap (Just . VType . mkType) (asks envPackage) 
    504 getMagical _            = return Nothing 
     541getMagical var = Map.findWithDefault (return Nothing) var magicalMap 
     542 
     543magicalMap :: Map Var (Eval (Maybe Val)) 
     544magicalMap = Map.fromList 
     545    [ (cast "$?FILE"     , posSym posName) 
     546    , (cast "$?LINE"     , posSym posBeginLine) 
     547    , (cast "$?COLUMN"   , posSym posBeginColumn) 
     548    , (cast "$?POSITION" , posSym pretty) 
     549