view release on metacpan or  search on metacpan

src/Pugs/Prim.hs  view on Meta::CPAN

    socket  <- guardIO $ listenOn (PortNumber $ fromInteger port)
    return $ VSocket socket
op1 "flush" = guardedIO hFlush
op1 "close" = \v -> do
    case v of
        (VSocket _) -> guardedIO sClose v
        _           -> guardedIO hClose v
op1 "Pair::key" = fmap fst . (fromVal :: Val -> Eval VPair)
op1 "Pair::value" = \v -> do
    ivar <- join $ doPair v pair_fetchElem
    return . VRef . MkRef $ ivar
op1 "pairs" = \v -> do
    pairs <- pairsFromVal v
    retSeq pairs
op1 "List::kv" = \v -> do
    pairs <- pairsFromVal v
    kvs   <- forM pairs $ \(VRef ref) -> do
        pair   <- readRef ref
        fromVal pair
    retSeq $ concat kvs
op1 "Pair::kv" = op1 "List::kv"
op1 "keys" = keysFromVal
op1 "values" = valuesFromVal
-- According to Damian
-- (http://www.nntp.perl.org/group/perl.perl6.language/21895),
-- =$obj should call $obj.next().
op1 "="        = \v -> case v of
    VObject _               -> evalExp $ App (_Var "&shift") (Just $ Val v) []
    VRef (MkRef IArray{})   -> do
        ifListContext
            (fmap VList (join $ doArray v array_fetch))
            (join $ doArray v array_shift)
    _           -> op1 "readline" v
op1 "readline" = op1Readline
op1 "getc"     = op1Getc
op1 "WHAT"     = fmap VType . evalValType
op1 "List::end"   = \x -> fmap (castV . pred) (join $ doArray x array_fetchSize) -- monadic join
op1 "List::elems" = \x -> fmap castV (join $ doArray x array_fetchSize) -- monadic join
op1 "List::pop"   = \x -> join $ doArray x array_pop -- monadic join
op1 "List::shift" = \x -> join $ doArray x array_shift -- monadic join
op1 "pick"  = op1Pick
op1 "sum"   = op1Sum
op1 "min"   = op1Min
op1 "max"   = op1Max
op1 "uniq"  = op1Uniq
op1 "chr"   = op1Cast (VStr . (:[]) . chr)
op1 "ord"   = op1Cast $ \str -> if null str then undef else (castV . ord . head) str
op1 "hex"   = fail "hex() is not part of Perl 6 - use :16() instead."
op1 "oct"   = fail "oct() is not part of Perl 6 - use :8() instead."
op1 "log"   = op1Cast (VNum . log)
op1 "log10" = op1Cast (VNum . logBase 10)
op1 "from"  = op1Cast (castV . matchFrom)
op1 "to"    = op1Cast (castV . matchTo)
op1 "matches" = op1Cast (VList . matchSubPos)
op1 "gather" = \v -> do
    evl <- asks envEval
    evl (Syn "gather" [Val v])
op1 "Thread::yield" = const $ do
    guardSTM . unsafeIOToSTM $ yield
    return $ VBool True
op1 "DESTROYALL" = \x -> cascadeMethod id "DESTROY" x VUndef
-- [,] is a noop -- It simply returns the input list
op1 "prefix:[,]" = return
op1 "prefix:$<<" = op1SigilHyper SScalar
op1 "prefix:@<<" = op1SigilHyper SArray
op1 "prefix:%<<" = op1SigilHyper SHash
op1 "prefix:&<<" = op1SigilHyper SCode
op1 "Code::assoc" = op1CodeAssoc
op1 "Code::name"  = op1CodeName
op1 "Code::arity" = op1CodeArity
op1 "Code::body"  = op1CodeBody
op1 "Code::pos"   = op1CodePos
op1 "Code::signature" = op1CodeSignature
op1 "Code::retry_with" = \vs -> do
    cs  <- fromVals vs
    env <- ask
    let runInSTM v = runEvalSTM env . evalExp $ App (Val v) Nothing []
    guardSTM $ foldl1 orElse (map runInSTM cs)
op1 "IO::tell"    = \v -> do
    h <- fromVal v
    res <- guardIO $ hTell h
    return $ VInt res
op1 "Rat::numerator" = \(VRat t) -> return . VInt $ numerator t
op1 "Rat::denominator" = \(VRat t) -> return . VInt $ denominator t
op1 "TEMP" = \v -> do
    ref <- fromVal v
    val <- readRef ref
    return . VCode $ mkPrim
        { subBody = Prim . const $ do
            writeRef ref val
            retEmpty
        }
op1 "Pugs::Internals::hIsOpen" = op1IO hIsOpen
op1 "Pugs::Internals::hIsClosed" = op1IO hIsClosed
op1 "Pugs::Internals::hIsReadable" = op1IO hIsReadable
op1 "Pugs::Internals::hIsWritable" = op1IO hIsWritable
op1 "Pugs::Internals::hIsSeekable" = op1IO hIsSeekable
op1 "Pugs::Internals::reduceVar" = \v -> do
    str <- fromVal v
    evalExp (_Var str)
op1 "Pugs::Internals::rule_pattern" = \v -> do
    case v of
        VRule MkRulePGE{rxRule=re} -> return $ VStr re
        VRule MkRulePCRE{rxRuleStr=re} -> return $ VStr re
        _ -> fail $ "Not a rule: " ++ show v
op1 "Pugs::Internals::rule_adverbs" = \v -> do
    case v of
        VRule MkRulePGE{rxAdverbs=hash} -> return hash
        VRule MkRulePCRE{rxAdverbs=hash} -> return hash
        _ -> fail $ "Not a rule: " ++ show v
op1 "Pugs::Internals::current_pragma_value" = \v -> do
    name <- fromVal v
    prags <- asks envPragmas
    return $ findPrag name prags
    where
        findPrag :: String -> [Pragma] -> Val
        findPrag _ [] = VUndef
        findPrag n (this:rest)
            | n == pragName this = VInt $ toInteger $ pragDat this
            | otherwise          = findPrag n rest
op1 "Pugs::Internals::caller_pragma_value" = \v -> do
    caller <- asks envCaller
    case caller of
        Just env -> local (const env) (op1 "Pugs::Internals::current_pragma_value" v)
        _        -> return $ VUndef
op1 "eager" = \v -> do
    vlist <- fromVal v
    return $! VList $! deepSeq vlist vlist
op1 "Pugs::Internals::emit_yaml" = \v -> do
    glob <- filterPrim =<< asks envGlobal
    yml  <- liftIO $ showYaml (filterUserDefinedPad glob, v)
    return $ VStr yml
op1 "Object::HOW" = \v -> do
    typ     <- evalValType v
    evalExp $ _Var (':':'*':showType typ)
op1 "Class::name" = \v -> do
    cls     <- fromVal v
    meta    <- readRef =<< fromVal cls
    fetch   <- doHash meta hash_fetchVal
    str     <- fromVal =<< fetch "name"
    return str
op1 "Class::traits" = \v -> do
    cls     <- fromVal v
    meta    <- readRef =<< fromVal cls
    fetch   <- doHash meta hash_fetchVal
    str     <- fromVal =<< fetch "is"
    return str
op1 "vv" = toVV'
op1 other   = \_ -> fail ("Unimplemented unaryOp: " ++ other)

op1IO :: Value a => (Handle -> IO a) -> Val -> Eval Val
op1IO = \fun v -> do
    val <- fromVal v
    fmap castV (guardIO $ fun val)

op1SigilHyper :: VarSigil -> Val -> Eval Val
op1SigilHyper sig val = do
    vs <- fromVal val
    evalExp $ Syn "," (map (\x -> Syn (shows sig "{}") [Val x]) vs)

retSeq :: VList -> Eval Val
retSeq xs = length xs `seq` return (VList xs)

handleExitCode :: ExitCode -> Eval Val
handleExitCode exitCode = do
    glob    <- askGlobal
    errSV   <- findSymRef (cast "$!") glob
    writeRef errSV $ case exitCode of
        ExitFailure x   -> VInt $ toInteger x
        ExitSuccess     -> VUndef
    return (VBool $ exitCode == ExitSuccess)

cascadeMethod :: ([VStr] -> [VStr]) -> VStr -> Val -> Val -> Eval Val
cascadeMethod f meth v args = do
    typ     <- evalValType v
    pkgs    <- fmap f (pkgParents $ showType typ)
    named   <- case args of
        VUndef -> return Map.empty
        VType{}-> return Map.empty
        _      -> join $ doHash args hash_fetch

    -- Here syms is a list of (sym, tvar) tuples where tvar is the physical coderef
    -- The monad in the "do" below is List.
    syms <- forM pkgs $ \pkg -> do
        let sym = cast $ ('&':pkg) ++ "::" ++ meth
        maybeM (fmap (findSym sym) askGlobal) $ \ref -> do
            return (sym, ref)

    forM_ (nubBy (\(_, x) (_, y) -> x == y) (catMaybes syms)) $ \(sym, _) -> do
        enterEvalContext CxtVoid $
            App (Var sym) (Just $ Val v)
                [ Syn "named" [Val (VStr key), Val val]
                | (key, val) <- Map.assocs named
                ]
    return undef

op1Return :: Eval Val -> Eval Val
op1Return action = assertFrame FrameRoutine $ do
    sub   <- fromVal =<< readVar (cast "&?ROUTINE")
    -- If this is a coroutine, reset the entry point
    case subCont sub of
        Nothing -> action
        Just tvar -> do
            let thunk = (`MkThunk` anyType) . fix $ \redo -> do
                evalExp $ subBody sub
                liftSTM $ writeTVar tvar thunk
                redo
            liftSTM $ writeTVar tvar thunk
            action

op1Yield :: Eval Val -> Eval Val
op1Yield action = assertFrame FrameRoutine $ do
    sub   <- fromVal =<< readVar (cast "&?ROUTINE")
    case subCont sub of
        Nothing -> fail $ "cannot yield() from a " ++ pretty (subType sub)
        Just tvar -> callCC $ \esc -> do
            liftSTM $ writeTVar tvar (MkThunk (esc undef) anyType)
            action

op1ShiftOut :: Val -> Eval Val
op1ShiftOut v = retShift =<< do
    evl <- asks envEval
    evl $ case v of
        VList [x]   -> Val x
        _           -> Val v

op1Exit :: Val -> Eval a
op1Exit v = do
    rv <- fromVal v
    retControl . ControlExit $ if rv /= 0
        then ExitFailure rv else ExitSuccess

op1StrFirst :: (Char -> Char) -> Val -> Eval Val
op1StrFirst f = op1Cast $ VStr .

src/Pugs/Prim.hs  view on Meta::CPAN

op2 "Pugs::Internals::hSetBinaryMode" = \x y -> do
    fh    <- fromVal x
    mode  <- fromVal y
    guardIO $ hSetBinaryMode fh mode
    return $ VBool True
op2 "Pugs::Internals::openFile" = \x y -> do
    filename <- fromVal x
    mode     <- fromVal y
    hdl      <- guardIO $ do
        h <- openFile filename (modeOf mode)
        hSetBuffering h NoBuffering
        return h
    return $ VHandle hdl
    where
    modeOf "r"  = ReadMode
    modeOf "w"  = WriteMode
    modeOf "a"  = AppendMode
    modeOf "rw" = ReadWriteMode
    modeOf m    = error $ "unknown mode: " ++ m
op2 "exp" = \x y -> if defined y
    then op2Num (**) x y
    else op1Cast (VNum . exp) x
op2 "Pugs::Internals::sprintf" = \x y -> do
    -- a single argument is all Haskell can really handle.
    -- XXX printf should be wrapped in a catch so a mis-typed argument
    -- doesnt kill pugs with a runtime exception.
    -- XXX fail... doesnt?!
    str <- fromVal x
    arg <- fromVal y
    return $ VStr $ case arg of
       VNum n -> printf str n
       VRat r -> printf str ((fromRational r)::Double)
       VInt i -> printf str i
       VStr s -> printf str s
       _      -> fail "should never be reached given the type declared below"
op2 "system" = \x y -> do
    prog        <- fromVal x
    args        <- fromVals y
    exitCode    <- tryIO (ExitFailure (-1)) $
        rawSystem (encodeUTF8 prog) (map encodeUTF8 args)
    handleExitCode exitCode
op2 "crypt" = \x y -> opPerl5 "crypt" [x, y]
op2 "chmod" = \x y -> do
    mode  <- fromVal x
    files <- fromVals y
    rets  <- mapM (doBoolIO . flip setFileMode $ toEnum mode) files
    return . VInt . sum $ map bool2n rets
op2 "splice" = \x y -> do
    fetchSize   <- doArray x array_fetchSize
    len'        <- fromVal y
    sz          <- fetchSize
    let len = if len' < 0 then if sz > 0 then (len' `mod` sz) else 0 else len'
    op4 "splice" x y (castV (sz - len)) (VList [])
op2 "sort" = \x y -> do
    xs <- fromVals x
    ys <- fromVals y
    op1 "sort" . VList $ xs ++ ys
op2 "IO::say" = op2Print hPutStrLn
op2 "IO::print" = op2Print hPutStr
op2 "printf" = op3 "IO::printf" (VHandle stdout)
op2 "BUILDALL" = cascadeMethod reverse "BUILD"
op2 "Pugs::Internals::install_pragma_value" = \x y -> do
    name <- fromVal x
    val  <- fromVal y
    idat <- asks envInitDat
    idatval <- liftSTM $ readTVar idat
    --trace ("installing " ++ name ++ "/" ++ (show val)) $ return ()
    let prag = initPragmas idatval
    liftSTM $ writeTVar idat idatval{initPragmas = 
        MkPrag{ pragName=name, pragDat=val } : prag }
    return (VBool True)
op2 "Pugs::Internals::base" = \x y -> do
    base <- fromVal x
    case y of
        VRef{}  -> op2BasedDigits base =<< fromVal y
        VList{} -> op2BasedDigits base =<< fromVal y
        _       -> do
            str <- fromVal y
            op2BasedDigits base [ s | Just s <- map baseDigit str ]
op2 "HOW::does" = \t p -> do
    meta    <- readRef =<< fromVal t
    fetch   <- doHash meta hash_fetchVal
    name    <- fromVal =<< fetch "name"
    roles   <- fromVals p
    mixinRoles name roles
    return undef

op2 ('!':name) = \x y -> op1Cast (VBool . not) =<< op2 name x y
op2 other = \_ _ -> fail ("Unimplemented binaryOp: " ++ other)

baseDigit :: Char -> Maybe Val
baseDigit '.'       = return (VStr ".")
baseDigit ch | ch >= '0' && ch <= '9' = return (castV (ord ch - ord '0'))
baseDigit ch | ch >= 'a' && ch <= 'z' = return (castV (ord ch - ord 'a' + 10))
baseDigit ch | ch >= 'A' && ch <= 'Z' = return (castV (ord ch - ord 'A' + 10))
baseDigit _         = Nothing

op2BasedDigits :: VInt -> [Val] -> Eval Val
op2BasedDigits base vs
    | null post = do
        pre' <- mapM fromVal pre
        return $ VInt (asIntegral pre')
    | otherwise = do
        pre'  <- mapM fromVal pre
        post' <- mapM fromVal $ tail post
        return $ VRat (asFractional (0:post') + (asIntegral pre' % 1))
    where
    (pre, post) = break (== VStr ".") $ filter (/= VStr "_") vs
    asIntegral = foldl (\x d -> base * x + d) 0
    asFractional :: [VInt] -> VRat
    asFractional = foldr (\d x -> (x / (base % 1)) + (d % 1)) (0 % 1)

op2Print :: (Handle -> String -> IO ()) -> Val -> Val -> Eval Val
op2Print f h v = do
    handle <- fromVal h
    strs   <- mapM fromVal =<< case v of
        VList vs  -> return vs
        _         -> return [v]
    guardIO $ do
        f handle . concatMap encodeUTF8 $ strs
        return $ VBool True