Changeset 8208

Show
Ignore:
Timestamp:
12/13/05 12:18:12 (3 years ago)
Author:
autrijus
Message:

* bootstrapping of ::Class.isa(::Class) is complete.

try these in pil shell:

::Class.get_method('get_method')
::Class.add_method('foo', -> $x { self.get_method($x) })
::Class.foo('foo')

Location:
src
Files:
1 added
9 modified

Legend:

Unmodified
Added
Removed

  • src/PIL.hs

    r8205 r8208  
    3838                exps <- parseNativeLang src  
    3939                banner "Parsed" 
    40                 putStrLn =<< pretty exps 
     40                putStrLn =<< prettyM exps 
    4141                banner "Evaluated" 
    4242                (val, objs) <- evalNativeLang exps 
    43                 putStrLn =<< pretty val 
     43                putStrLn =<< prettyM val 
    4444                banner "Object Space" 
    4545                dumpObjSpace objs 
    … …  
    5656parse src = do 
    5757    exps <- parseNativeLang src 
    58     putStrLn =<< pretty exps 
     58    putStrLn =<< prettyM exps 
    5959    return () 
    6060 
    … …  
    6363    exps <- parseNativeLang src  
    6464    (val, objs) <- evalNativeLang exps 
    65     putStrLn =<< pretty val 
     65    putStrLn =<< prettyM val 
     66    banner "Object Space" 
    6667    dumpObjSpace objs 
    6768 

  • src/PIL/Native.hs

    r8205 r8208  
    55    parseNativeLang, 
    66    NativeLangExpression, 
    7     pretty, 
     7    pretty, prettyM, 
    88    dumpObjSpace, 
    99) where 

  • src/PIL/Native/Coerce.hs

    r8205 r8208  
    2828nil = toNative mkNil 
    2929 
     30emptySeq :: Native 
     31emptySeq = toNative (empty :: NativeSeq) 
     32 
     33emptyMap :: Native 
     34emptyMap = toNative (empty :: NativeMap) 
     35 
    3036mkNil :: NativeError 
    3137mkNil = NonTermination 
    … …  
    5965    isEmpty     :: a -> NativeBit 
    6066    size        :: a -> NativeInt 
     67    exists      :: a -> key -> Bool 
    6168    empty       :: a 
    6269    indices     :: a -> [key] 
    … …  
    7582    size       = NStr.length 
    7683    empty      = NStr.empty 
     84    exists (NStr.PS _ _ l) n = (n >= 0) && (n < l) 
    7785    indices    = \x -> [0 .. (NStr.length x - 1)] 
    7886    elems      = NStr.elems 
    … …  
    93101    indices    = NMap.keys 
    94102    elems      = NMap.elems 
     103    exists     = flip NMap.member 
    95104    append     = NMap.union 
    96105    push       = error "It doesn't make sense to push into a hash" 
    … …  
    102111 
    103112instance IsPlural (SeqOf a) NativeInt a where 
    104     isEmpty    = NSeq.null 
    105     size       = NSeq.length 
    106     empty      = NSeq.empty 
    107     indices    = \x -> [0 .. size x - 1] 
    108     elems      = NSeq.toList 
    109     append     = (NSeq.><) 
    110     push       = append 
    111     assocs     = ([0..] `zip`) . elems 
    112     fromAssocs = NSeq.fromList . map snd -- XXX wrong 
    113     fetch x y  = Just (NSeq.index x y) -- XXX wrong 
    114     insert     = \x k v -> NSeq.update k v x 
    115     (!)        = NSeq.index 
     113    isEmpty      = NSeq.null 
     114    size         = NSeq.length 
     115    empty        = NSeq.empty 
     116    exists x n   = (n >= 0) && (n < size x) 
     117    indices      = \x -> [0 .. size x - 1] 
     118    elems        = NSeq.toList 
     119    append       = (NSeq.><) 
     120    push         = append 
     121    assocs       = ([0..] `zip`) . elems 
     122    fromAssocs   = NSeq.fromList . map snd -- XXX wrong 
     123    fetch x y    = Just (NSeq.index x y) -- XXX wrong 
     124    insert x k v | k == size x = (NSeq.|>) x v 
     125    insert x k v = NSeq.update k v x 
     126    (!)          = NSeq.index 
    116127 
    117128class Show a => IsNative a where  
    … …  
    201212    fromNative x            = castFail x 
    202213 
     214instance IsNative NativeObj where 
     215    toNative = NObj 
     216    fromNative (NObj x)     = x 
     217    fromNative x            = castFail x 
     218 
    203219instance IsNative NativeError where 
    204220    toNative = NError 
    … …  
    243259castFail :: a -> b 
    244260castFail _ = error "cast fail" 
     261 
     262failWith :: (Monad m, IsNative a) => String -> a -> m b 
     263failWith msg s = fail $ msg ++ ": " ++ toString s 

  • src/PIL/Native/Eval.hs

    r8205 r8208  
    11{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-} 
    22 
    3 module PIL.Native.Eval where 
     3module PIL.Native.Eval (evalNativeLang) where 
    44import PIL.Native.Prims 
    55import PIL.Native.Types 
    66import PIL.Native.Coerce 
    77import PIL.Native.Objects 
     8import PIL.Native.Parser 
    89import Data.FunctorM 
    910import Control.Monad.State 
    … …  
    2425-} 
    2526 
    26 type Eval = StateT ObjectSpace (ReaderT Pad SIO) 
     27type Eval = StateT ObjectSpace (ReaderT Pad IO) 
    2728type Pad = NativeMap 
    2829 
    … …  
    3031    liftSTM = lift . lift . liftSTM 
    3132 
    32 evalNativeLang :: MonadSTM m => [NativeLangExpression] -> m (Native, ObjectSpace) 
    33 evalNativeLang = runSIO . (`runReaderT` empty) . (`runStateT` empty) . evalMain 
     33-- evalNativeLang :: MonadSTM m => [NativeLangExpression] -> m (Native, ObjectSpace) 
     34evalNativeLang :: [NativeLangExpression] -> IO (Native, ObjectSpace) 
     35evalNativeLang = (`runReaderT` empty) . (`runStateT` empty) . evalMain 
    3436 
    3537evalMain :: [NativeLangExpression] -> Eval Native 
    36 evalMain exps = do 
    37     -- bootstrap 
     38evalMain exps = bootstrapClass $ do 
     39    addClassMethods 
    3840    evalExps exps 
     41 
     42addClassMethods :: Eval Native 
     43addClassMethods = do 
     44    add "has_method"        "-> $name { self.get_attr('%methods').exists($name) }" 
     45    add "get_method"        "-> $name { self.get_attr('%methods').fetch($name) }" 
     46    add "get_method_list"   "-> $name { self.get_attr('%methods').keys() }" 
     47    add "new"               "-> %prms { self.bless(nil, %prms) }" 
     48    add "bless"           $ "-> $repr, %prms {                              \ 
     49                          \     -> $obj { $obj.BUILDALL(%prms); $obj; }     \ 
     50                          \         .(self.CREATE($repr, %prms))            \ 
     51                          \  }" 
     52    add "CREATE"          $ "-> $repr, %prms {} " -- XXX - not finished yet 
     53    where 
     54    add name body = eval $ "::Class.add_method('" ++ name ++ "', " ++ body ++ ")" 
     55 
     56eval :: String -> Eval Native 
     57eval = evalExp . parseExp 
     58 
     59bootstrapClass :: Eval a -> Eval a 
     60bootstrapClass x = mdo 
     61    cls <- newObject cls 
     62        [ ("@MRO",              emptySeq) 
     63        , ("@subclasses",       emptySeq) 
     64        , ("@superclasses",     emptySeq) 
     65        , ("%private_methods",  emptyMap) 
     66        , ("%attributes",       emptyMap) 
     67        , ("%methods", toNative $ mkMap [("add_method", addMethod)]) 
     68        ] 
     69    enterLex [("::Class", cls)] x 
     70    where 
     71    addMethod = parseSub 
     72        "-> $name, &method { self.set_attr_hash('%methods', $name, &method) }" 
     73 
     74enterLex :: IsNative a => [(String, a)] -> Eval b -> Eval b 
     75enterLex = local . append . mkMap . map (\(x, y) -> (x, toNative y)) 
    3976 
    4077evalExps :: [NativeLangExpression] -> Eval Native 
    … …  
    4986    case pad `fetch` s of 
    5087        Just v  -> return v 
    51         Nothing -> fail $ "No such variable " ++ toString s 
     88        Nothing -> failWith "No such variable" s 
    5289evalExp (ECall { c_obj = objExp, c_meth = meth, c_args = argsExp }) = do 
    5390    obj  <- evalExp objExp 
    … …  
    71108    where 
    72109    errMethodMissing :: Eval a 
    73     errMethodMissing = fail ("No such method: " ++ toString meth) 
     110    errMethodMissing = failWith "No such method" meth 
    74111    callMethod :: MapOf (a -> b -> Native) -> a -> b -> Eval Native 
    75112    callMethod prims x args = case prims `fetch` meth of 
    … …  
    91128callConditional x args = callSub (fromNative $ args ! fromEnum (not x)) empty 
    92129 
     130infixl ... 
     131(...) :: IsNative a => NativeObj -> String -> Eval a 
     132obj ... str = fmap fromNative $ getAttr obj (mkStr str) 
     133 
    93134callObject :: NativeObj -> NativeStr -> NativeSeq -> Eval Native 
    94 callObject obj meth args = do 
    95     mro <- getAttr obj (mkStr "@:MRO") 
    96     return mro 
     135callObject obj meth args = enterLex lex $ do 
     136    meths <- cls ... "%methods" :: Eval NativeMap 
     137    case meths `fetch` meth of 
     138        Just x  -> callSub (fromNative x) args 
     139        _       -> tryMRO =<< getMRO 
    97140    where 
     141    lex = [("$?SELF", obj), ("$?CLASS", cls)] 
    98142    cls = o_class obj 
     143    getMRO = do 
     144        mro <- cls ... "@MRO" :: Eval NativeSeq 
     145        if isEmpty mro 
     146            then cls ... "@superclasses" 
     147            else return (elems mro) 
     148    tryMRO [] | meth == mkStr "get_attr" = do 
     149        obj ... fromNative (args ! 0) 
     150    tryMRO [] | meth == mkStr "set_attr_hash" = do 
     151        let [attrVal, keyVal, val] = elems args 
     152            key :: NativeStr = fromNative keyVal 
     153        hash <- obj ... fromNative attrVal :: Eval NativeMap 
     154        setAttr obj (fromNative attrVal) (toNative $ insert hash key val) 
     155        return nil 
     156    tryMRO [] = failWith "No such method" meth 
     157    tryMRO (c:cs) = do 
     158        meths <- fromNative c ... "%methods" :: Eval NativeMap 
     159        case meths `fetch` meth of 
     160            Just x  -> callSub (fromNative x) args 
     161            _       -> tryMRO cs 

  • src/PIL/Native/Objects.hs

    r8206 r8208  
    11{-# OPTIONS_GHC -fglasgow-exts #-} 
    22 
    3 module PIL.Native.Objects (ObjectSpace, dumpObjSpace, getAttr) where 
     3module PIL.Native.Objects ( 
     4    ObjectSpace, 
     5    dumpObjSpace, 
     6    newObject, 
     7    getAttr, setAttr, addAttr, 
     8) where 
    49import PIL.Native.Coerce 
    510import PIL.Native.Types 
    611import PIL.Native.Pretty 
    712import System.Mem.Weak 
    8 import Control.Monad 
     13import Control.Monad.State 
    914 
    1015type ObjectSpace = SeqOf (Weak NativeObj) 
    1116 
    1217dumpObjSpace :: ObjectSpace -> IO () 
    13 dumpObjSpace ptrs = mapM_ dumpObj (assocs ptrs) 
     18dumpObjSpace ptrs = mapM_ dumpObj (elems ptrs) 
    1419    where 
    15     dumpObj (idx, ptr) = do 
     20    dumpObj ptr = do 
    1621        rv <- deRefWeak ptr 
    1722        case rv of 
    18             Just obj -> do 
    19                 putStr $ show idx ++ ": " 
    20                 putStrLn =<< pretty obj 
    21             Nothing -> return () 
     23            Just obj -> putStrLn (pretty obj) 
     24            Nothing  -> return () 
    2225 
    2326getAttr :: MonadSTM m => NativeObj -> NativeStr -> m Native 
    … …  
    2629    case attrs `fetch` att of 
    2730        Just val -> return val 
    28         Nothing  -> fail "no such attribute" 
     31        Nothing  -> failWith "no such attribute" att 
     32 
     33setAttr :: MonadSTM m => NativeObj -> NativeStr -> Native -> m () 
     34setAttr obj att val = do 
     35    let tvar = o_attrs obj 
     36    attrs <- liftSTM $ readTVar tvar 
     37    unless (exists attrs att) $ failWith "no such attribute" att 
     38    liftSTM $ writeTVar tvar (insert attrs att val) 
     39 
     40addAttr :: MonadSTM m => NativeObj -> NativeStr -> m () 
     41addAttr obj att = do 
     42    let tvar = o_attrs obj 
     43    attrs <- liftSTM $ readTVar tvar 
     44    when (exists attrs att) $ failWith "already got attribute" att 
     45    liftSTM $ writeTVar tvar (insert attrs att nil) 
     46 
     47newObject :: (MonadState ObjectSpace m, MonadIO m, MonadSTM m) => 
     48    NativeObj -> [(String, Native)] -> m NativeObj 
     49newObject cls pairs = do 
     50    attrs <- liftSTM $ newTVar (mkMap pairs) 
     51    objs  <- get 
     52    let obj = MkObject oid cls attrs 
     53        oid = size objs 
     54    ptr <- liftIO $ mkWeak attrs obj Nothing 
     55    put (insert objs oid ptr) 
     56    return obj 

  • src/PIL/Native/Parser.hs

    r8205 r8208  
    6161 
    6262parseNativeLang :: Monad m => String -> m [NativeLangExpression] 
    63 parseNativeLang src = case ( runParser program () "-" src ) of 
     63parseNativeLang src = case parse program "-" src of 
    6464    Left err    -> fail (show err) 
    6565    Right exp   -> return exp 
    6666    where 
    6767    program = between bof eof (semiColonSep expression) 
    68     bof = return () 
     68 
     69parseWith :: Parser a -> String -> a 
     70parseWith p src = case parse (between bof eof p) src src of 
     71    Left err    -> error (show err) 
     72    Right exp   -> exp 
     73 
     74bof :: Parser () 
     75bof = whiteSpace 
     76 
     77parseSub :: String -> Native 
     78parseSub = toNative . parseWith pointySub 
     79 
     80parseExp :: String -> NativeLangExpression 
     81parseExp = parseWith expression 
    6982 
    7083expression :: Parser NativeLangExpression 
    … …  
    7285    obj <- choice 
    7386        [ parens expression 
     87        , selfExpression 
    7488        , arrayExpression 
    7589        , fmap ELit literal 
    … …  
    95109        args    <- option [] (parens $ commaSep expression) 
    96110        return (name, args) 
     111    selfExpression = do 
     112        symbol "self" 
     113        return (EVar $ mkStr "$?SELF") 
    97114 
    98115literal :: Parser Native 

  • src/PIL/Native/Pretty.hs

    r8205 r8208  
    11{-# OPTIONS_GHC -cpp -fglasgow-exts #-} 
    22 
    3 module PIL.Native.Pretty (Pretty(..), pretty) where 
     3module PIL.Native.Pretty (Pretty(..), pretty, prettyM) where 
    44import PIL.Native.Types 
    55import PIL.Native.Coerce 
    … …  
    1919-} 
    2020 
    21 pretty :: (Functor m, MonadSTM m, Pretty a) => a -> m String 
    22 pretty a = fmap render $ formatM a 
     21pretty :: (Pretty a) => a -> String 
     22pretty = render . format 
     23 
     24prettyM :: (MonadSTM m, Pretty a) => a -> m String 
     25prettyM a = fmap render $ formatM a 
     26 
     27defaultIndent :: Int 
     28defaultIndent = 2 
    2329 
    2430class (Show a) => Pretty a where 
    … …  
    4854instance Pretty NativeSub where 
    4955    format (MkSub params body) = hang 
    50         (text "->" <+> commaSep (elems params)) 2 
     56        (text "->" <+> commaSep (elems params)) defaultIndent 
    5157        (braces . format . elems $ body) 
    5258 
    … …  
    6268    format (NSub x)     = format x 
    6369    format (NObj x)     = format x 
     70    formatM (NObj x)    = formatM x 
     71    formatM (NSeq x)    = formatM x 
     72    formatM (NMap x)    = formatM x 
     73    formatM x           = return (format x) 
    6474 
    6575instance Pretty NativeObj where 
     76    format o = text $ "<obj:#" ++ show (o_id o) ++ "|cls:#" ++ show (o_id (o_class o)) ++ ">" 
     77    formatM o = do 
     78        attrs <- liftSTM $ readTVar (o_attrs o) 
     79        formatM attrs 
     80 
     81instance Pretty NativeSeq where 
     82    format x = brackets (nest defaultIndent (commaSep $ elems x)) 
     83    formatM x = do 
     84        items <- commaSepM $ elems x 
     85        return $ brackets (nest defaultIndent items) 
     86 
     87instance Pretty NativeMap where 
     88    format x = braces (nest defaultIndent (commaSep $ assocs x)) 
     89    formatM x = do 
     90        pairs <- commaSepM $ assocs x 
     91        return $ braces (nest defaultIndent pairs) 
     92 
     93instance Pretty Doc where 
     94    format = id 
    6695 
    6796instance Pretty String where 
    … …  
    74103sepBy x = sep . punctuate x . map format 
    75104 
     105sepByM :: (MonadSTM m, Pretty a) => Doc -> [a] -> m Doc 
     106sepByM x = fmap (sep . punctuate x) . mapM formatM 
     107 
    76108commaSep :: Pretty a => [a] -> Doc 
    77109commaSep = sepBy comma 
     110 
     111commaSepM :: (MonadSTM m, Pretty a) => [a] -> m Doc 
     112commaSepM = sepByM comma 
     113 

  • src/PIL/Native/Prims.hs

    r8205 r8208  
    6767  concat (Any)      -> Nil 
    6868  fetch  (Any)      -> Any 
     69  exists (Any)      -> Any 
    6970  store  (Any, Any) -> Nil 
    7071  push   (Hash)     -> Nil   
    … …  
    148149    , prim1 "concat"     (append) 
    149150    , prim1 "fetch"      (fetch) 
     151    , prim1 "exists"     (exists) 
    150152    , prim2 "store"      (insert) 
    151153    , primX "push"       (pushHash) 

  • src/PIL/Native/Types.hs

    r8205 r8208  
    6060 
    6161data NativeObj = MkObject 
    62     { o_class   :: NativeObj -- ::Class is self-recursive, so can't be strict here 
    63     , o_id      :: !ObjectId 
     62    { o_id      :: !ObjectId 
     63    , o_class   :: NativeObj -- ::Class is self-recursive, so can't be strict here 
    6464    , o_attrs   :: !ObjectAttrs 
    6565    } 
    … …  
    9797instance Ord NativeError where 
    9898    compare x y = compare (show x) (show y) 
     99