root/src/Pugs/Prim.hs

{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-full-laziness -fno-cse -fallow-overlapping-instances #-}

{-|
    Primitive operators.

>   There hammer on the anvil smote,
>   There chisel clove, and graver wrote;
>   There forged was blade, and bound was hilt;
>   The delver mined, the mason built...
-}

module Pugs.Prim (
    primOp,
    primDecl,
    initSyms,
    op2ChainedList,
    op1Exit,

    -- used by Pugs.Compile.Haskell
    op0, op1, op2,

    -- used Pugs.Eval
    op1Return, op1Yield,
    foldParam, op2Hyper, op1HyperPrefix, op1HyperPostfix, retSeq, atomicEval
) where
import Pugs.Internals
import Pugs.Junc
import Pugs.AST
import Pugs.Types
import Pugs.Monads
import Pugs.Pretty
import Pugs.DeepSeq
import Text.Printf
import Pugs.External
import Pugs.Embed
import Pugs.Eval.Var
import Pugs.Meta ()
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.IORef
import System.IO.Error (isEOFError)
import Control.Exception (ioErrors)

import Pugs.Prim.Keyed
import Pugs.Prim.Yaml
import Pugs.Prim.Match
import Pugs.Prim.List
import Pugs.Prim.Numeric
import Pugs.Prim.Lifts
import Pugs.Prim.Eval
import Pugs.Prim.Code
import Pugs.Prim.Param
import qualified Data.IntSet as IntSet
import DrIFT.YAML
import GHC.Exts (unsafeCoerce#)
import GHC.Unicode
import qualified Data.HashTable as H
import Data.Time.LocalTime
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.MonthDay

constMacro :: Exp -> [Val] -> Eval Val
constMacro = const . expToEvalVal

-- |Implementation of 0-ary and variadic primitive operators and functions
-- (including list ops).
op0 :: String -> [Val] -> Eval Val
op0 "&"  = fmap opJuncAll . mapM fromVal
op0 "^"  = fmap opJuncOne . mapM fromVal
op0 "|"  = fmap opJuncAny . mapM fromVal
op0 "want"  = const $ fmap VStr (asks (maybe "Item" envWant . envCaller))
op0 "Bool::True"  = const . return $ VBool True
op0 "Bool::False" = const . return $ VBool False
op0 "True"  = constMacro . Val $ VBool True
op0 "False" = constMacro . Val $ VBool False
op0 "time"  = const $ do
    clkt <- guardIO getCurrentTime
    return $ VRat $ pugsTimeSpec clkt
op0 "times"  = const $ do
    ProcessTimes _ u s cu cs <- guardIO getProcessTimes
    return . VList $ map (castV . (% (clocksPerSecond :: VInt)) . toInteger . fromEnum)
        [u, s, cu, cs]
op0 "Z" = op0Zip
op0 "X" = op0Cross
    -- op0 "minmax" = op0Minmax
op0 "File::Spec::cwd" = const $ do
    cwd <- guardIO getCurrentDirectory
    return $ VStr cwd
op0 "File::Spec::tmpdir" = const $ do
    tmp <- guardIO getTemporaryDirectory
    return $ VStr tmp
op0 "Pugs::Internals::pi" = const $ return $ VNum pi
op0 "self"    = const $ expToEvalVal (_Var "$__SELF__")
op0 "say"     = const $ op1 "IO::say" (VHandle stdout)
op0 "print"   = const $ op1 "IO::print" (VHandle stdout)
op0 "return"  = const $ op1Return (retControl (ControlLeave (<= SubRoutine) 0 undef))
op0 "yield"   = const $ op1Yield (retControl (ControlLeave (<= SubRoutine) 0 undef))
op0 "leave"   = const $ retControl (ControlLeave (>= SubBlock) 0 undef)
op0 "take"    = const $ assertFrame FrameGather retEmpty
op0 "nothing" = const . return $ VBool True
op0 "Pugs::Safe::safe_getc"     = const . op1Getc $ VHandle stdin
op0 "Pugs::Safe::safe_readline" = const . op1Readline $ VHandle stdin
op0 "reverse" = const $ return (VList [])
op0 "chomp"   = const $ return (VList [])
op0 "fork"    = const $ opPerl5 "fork" []
op0 "defer"   = const $ do
    env <- ask
    if envAtomic env then guardSTM retry else fail "Cannot call &defer outside a contend block."
op0 other = const $ fail ("Unimplemented listOp: " ++ other)

-- |Implementation of unary primitive operators and functions
op1 :: String -> Val -> Eval Val
op1 "!"    = op1Cast (VBool . not)
op1 "WHICH" = \x -> do
    val <- fromVal x
    return $ case val of
        VObject o   -> castV . unObjectId $ objId o
        _           -> val
op1 "chop" = \x -> do
    str <- fromVal x
    return $ if null str
        then VStr str
        else VStr $ init str
op1 "Scalar::chomp" = \x -> do
    str <- fromVal x
    return $ op1Chomp str
op1 "Str::split" = op1Cast (castV . words)
op1 "lc"         = op1Cast (VStr . map toLower)
op1 "lcfirst"    = op1StrFirst toLower
op1 "uc"         = op1Cast (VStr . map toUpper)
op1 "ucfirst"    = op1StrFirst toUpper
op1 "capitalize" = op1Cast $ VStr . (mapEachWord capitalizeWord)
  where
    mapEachWord _ [] = []
    mapEachWord f str@(c:cs)
        | isSpace c = c:(mapEachWord f cs)
        | otherwise = f word ++ mapEachWord f rest
          where (word,rest) = break isSpace str
    capitalizeWord []     = []
    capitalizeWord (c:cs) = toUpper c:(map toLower cs)
op1 "quotemeta" = op1Cast (VStr . concat . map toQuoteMeta)
op1 "undef" = const $ return undef
op1 "undefine" = \x -> do
    when (defined x) $ do
        ref <- fromVal x
        clearRef ref
    return undef
op1 "+"    = op1Numeric id
op1 "abs"  = op1Numeric abs
op1 "Pugs::Internals::truncate" = op1Round truncate
op1 "Pugs::Internals::round"    = op1Round round
op1 "Pugs::Internals::floor"    = op1Round floor
op1 "Pugs::Internals::ceiling"  = op1Round ceiling
op1 "cos"  = op1Floating cos
op1 "sin"  = op1Floating sin
op1 "tan"  = op1Floating tan
op1 "sqrt" = op1Floating sqrt
op1 "atan" = op1Floating atan
op1 "post:i" = \x -> do
    n <- fromVal x
    return $ VComplex (0 :+ n)
op1 "post:++" = \x -> atomicEval $ do
    ref <- fromVal x
    val <- fromVal x
    val' <- case val of
        (VStr str)  -> return (VStr $ strInc str)
        _           -> op1Numeric (+1) val
    writeRef ref val'
    case val of
        (VStr _)    -> return val
        _           -> op1 "+" val
op1 "++"   = \mv -> do
    op1 "post:++" mv
    fromVal mv
op1 "post:--"   = \x -> atomicEval $ do
    ref <- fromVal x
    val <- fromVal x
    writeRef ref =<< op1Numeric (\x -> x - 1) val
    return val
op1 "--"   = \mv -> do
    op1 "post:--" mv
    fromVal mv
op1 "-"    = op1Numeric negate
op1 "item" = \v -> return $ case v of
    VList vs    -> VRef . arrayRef $ vs
    _           -> v
op1 "sort" = \v -> do
    args    <- fromVal v
    (valList, sortByGiven) <- case args of
        (v:vs) -> do
            ifValTypeIsa v "Code"
                (return (vs, Just v))
                (ifValTypeIsa (last args) "Code"
                    (return (init args, Just $ last args))
                    (return (args, Nothing)))
        _  -> return (args, Nothing)
    sortBy <- case sortByGiven of
        Nothing -> readVar (cast "&*infix:cmp")
        Just subVal -> return subVal
    sub <- fromVal sortBy
    sorted <- (`sortByM` valList) $ \v1 v2 -> do
        rv  <- enterEvalContext (cxtItem "Int") $ App (Val sub) Nothing [Val v1, Val v2]
        int <- fromVal rv
        return (int <= (0 :: Int))
    retSeq sorted
op1 "Scalar::reverse" = \v -> do
    str     <- fromVal v
    return (VStr $ reverse str)
op1 "List::reverse" = \v -> do
    vlist <- fromVal v
    return (VList $ reverse vlist)
op1 "list" = op1Cast VList
op1 "pair" = op1Cast $ VList . (map $ \(k, v) -> castV ((VStr k, v) :: VPair))
op1 "~"    = op1Cast VStr
op1 "?"    = op1Cast VBool
op1 "int"  = op1Cast VInt
op1 "+^"   = op1Cast (VInt . pred . negate) -- Arbitrary precision complement- 0 ==> -1 / 1 ==> -2
op1 "~^"   = op1Cast (VStr . mapStr complement)
op1 "?^"   = op1 "!"
op1 "\\"   = \v -> do
    return $ case v of
        (VRef (MkRef (IScalar _))) -> VRef . scalarRef $ v
        (VRef _)    -> v
        (VList vs)  -> VRef . arrayRef $ vs
        _           -> VRef . scalarRef $ v
op1 "^" = op2RangeExclRight (VNum 0)
op1 "post:..."  = op1Range
op1 "not"  = op1 "!"
op1 "true" = op1 "?"
op1 "any"  = op1Cast opJuncAny
op1 "all"  = op1Cast opJuncAll
op1 "one"  = op1Cast opJuncOne
op1 "none" = op1Cast opJuncNone
op1 "perl" = op1Pretty $ MkPrettyPrinter pretty
op1 "guts" = op1Pretty $ MkPrettyPrinter priggy
op1 "yaml" = dumpYaml
op1 "require_haskell" = \v -> do
    name    <- fromVal v
    externRequire "Haskell" name
    return $ VBool True
op1 "require_parrot" = \v -> do
    name    <- fromVal v
    io $ evalParrotFile name
    return $ VBool True
op1 "require_perl5" = \v -> do
    pkg     <- fromVal v
    let requireLine = "require " ++ pkg ++ "; '" ++ pkg ++ "'"
    val     <- evalPerl5WithCurrentEnv requireLine
    evalExp (_Sym SOur (':':'*':pkg) mempty (Val val) (newMetaType pkg))
    return val
op1 "require_java" = \v -> do
    pkg     <- fromVal v
    let requireLine = "package main; use Inline (qw( Java STUDY AUTOSTUDY 1 STUDY ), ['" ++ mod ++ "']); '" ++ pkg ++ "'"
        lastPart    = last (split "::" pkg)
        mod         = concat (intersperse "." (split "::" pkg))
    val     <- evalPerl5WithCurrentEnv requireLine
    evalExp (_Sym SOur (':':'*':pkg) mempty (Val val) (newMetaType pkg))
    when (lastPart /= pkg) $ do
        evalExp_ (_Sym SOur (':':'*':lastPart) mempty (Val val) (newMetaType lastPart))
    return val
op1 "Pugs::Internals::eval_parrot" = \v -> do
    code    <- fromVal v
    io . evalParrot $ case code of
        ('.':_) -> code
        _       -> unlines
            [ ".sub pugs_eval_parrot"
            -- , "trace 1"
            , code
            , ".end"
            ]
    return $ VBool True

-- XXX - revert these two to Prelude.pm's ::Disabled version once YAML+Closure is working
op1 "use" = opRequire True 
op1 "require" = opRequire False

op1 "Pugs::Internals::use" = opRequire True
op1 "Pugs::Internals::require" = opRequire False
op1 "Pugs::Internals::eval_perl6" = \v -> do
    str <- fromVal v
    opEval quiet "<eval>" (encodeUTF8 str)
    where quiet = MkEvalStyle { evalResult = EvalResultLastValue
                              , evalError  = EvalErrorUndef }
op1 "evalfile" = \v -> do
    filename <- fromVal v
    opEvalFile filename
op1 "Pugs::Internals::eval_perl5" = \v -> do
    str     <- fromVal v
    env     <- ask
    lex     <- asks envLexical
    let vars = [ v | v@MkVar{ v_sigil = SScalar, v_twigil = TNil } <- Set.toList (padKeys lex), v /= varTopic ]
        code = "sub { " ++ codeSafe ++ codeVar ++ str ++ "\n}"
        codeSafe | safeMode  = "use ops (':default', 'binmode', 'entereval');"
                 | otherwise = ""
        codeVar | null vars = ""
                | otherwise = "my (" ++ (concat $ intersperse ", " (map cast vars)) ++ ") = @_;"
    vals    <- mapM readVar vars
    rv  <- tryIO (Perl5ErrorString "") $ do
        envSV   <- mkEnv env
        sub     <- evalPerl5 code envSV 0
        args    <- mapM newSVval vals
        invokePerl5 sub nullSV args envSV (enumCxt $ envContext env)
    case rv of
        Perl5ReturnValues [x]   -> io $ svToVal x
        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs)
        Perl5ErrorString str    -> fail str
        Perl5ErrorObject err    -> throwError (PerlSV err)
op1 "Pugs::Internals::evalfile_p6y" = op1EvalFileP6Y
op1 "Pugs::Internals::eval_p6y"     = op1EvalP6Y
op1 "Pugs::Internals::eval_haskell" = op1EvalHaskell
op1 "Pugs::Internals::eval_yaml" = evalYaml
op1 "contend" = \v -> do
    env <- ask
    guardSTM . runEvalSTM env . evalExp $ App (Val v) Nothing []
op1 "try" = \v -> do
    sub <- fromVal v
    env <- ask
    val <- tryT $ case envAtomic env of
        True    -> guardSTM . runEvalSTM env . evalExp $ App (Val $ VCode sub) Nothing []
        False   -> guardIO . runEvalIO env . evalExp $ App (Val $ VCode sub) Nothing []
    retEvalResult style val
    where
    style = MkEvalStyle
        { evalResult = EvalResultLastValue
        , evalError  = EvalErrorUndef
        }
-- Tentative implementation of nothingsmuch's lazy proposal.
op1 "lazy" = \v -> do
    sub     <- fromVal v
    memo    <- io $ newTVarIO Nothing
    let exp = App (Val $ VCode sub) Nothing []
        thunk = do
            cur <- stm $ readTVar memo
            maybe eval return cur
        eval = do
            res <- evalExp exp
            stm $ writeTVar memo (Just res)
            return res
    typ <- inferExpType exp
    return . VRef . thunkRef $ MkThunk thunk typ

op1 "defined" = op1Cast (VBool . defined)
op1 "last" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopLast))
op1 "next" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopNext))
op1 "redo" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopRedo))
op1 "continue" = const $ assertFrame FrameWhen $ op1ShiftOut (VControl (ControlWhen WhenContinue))
op1 "break" = const $ assertFrame FrameWhen $ op1ShiftOut (VControl (ControlWhen WhenBreak))
op1 "return" = op1Return . op1ShiftOut . VControl . ControlLeave (<= SubRoutine) 0
op1 "yield" = op1Yield . op1ShiftOut . VControl . ControlLeave (<= SubRoutine) 0
op1 "leave" = op1ShiftOut . VControl . ControlLeave (>= SubBlock) 0
op1 "take" = \v -> assertFrame FrameGather $ do
    glob    <- askGlobal
    arr     <- findSymRef (cast "$*TAKE") glob
    push    <- doArray (VRef arr) array_push
    push (listVal v)
    retEmpty
op1 "sign" = \v -> withDefined [v] $
    op1Cast (VInt . signum) v

op1 "srand" = \v -> do
    x <- fromVal v
    guardSTM . unsafeIOToSTM $ do
       seed <- if defined v
          then return x
          else randomRIO (0, 2^(31::Int))
       setStdGen $ mkStdGen seed
    return (castV True)
op1 "rand"  = \v -> do
    x    <- fromVal v
    rand <- guardSTM . unsafeIOToSTM
               $ getStdRandom (randomR (0, if x == 0 then 1 else x))
    return $ VNum rand
op1 "say" = op2 "IO::say" (VHandle stdout)
op1 "print" = op2 "IO::print" (VHandle stdout)
op1 "IO::say" = \v -> op2 "IO::say" v $ VList []
op1 "IO::print" = \v -> op2 "IO::print" v $ VList []
op1 "IO::next" = \v -> do
    fh  <- fromVal v
    guardIO $ fmap (VStr . (++ "\n") . decodeUTF8) (hGetLine fh)
op1 "Pugs::Safe::safe_print" = \v -> do
    str  <- fromVal v
    guardIO . putStr $ encodeUTF8 str
    return $ VBool True
op1 "die" = \v -> do
    v'      <- fromVal $! v
    poss    <- asks envPosStack
    retShift $! VError (errmsg $! v') poss
    where
    errmsg VUndef      = VStr "Died"
    errmsg VType{}     = VStr "Died"
    errmsg (VStr "")   = VStr "Died"
    errmsg (VList [])  = VStr "Died"
    errmsg (VList [x]) = x
    errmsg x           = x
op1 "warn" = \v -> do
    strs <- fromVal v
    errh <- readVar $ cast "$*ERR"
    poss    <- asks envPosStack
    op2 "IO::say" errh $ VList [ VStr $ pretty (VError (errmsg strs) poss) ]
    where
    errmsg "" = VStr "Warning: something's wrong"
    errmsg x  = VStr x
op1 "fail" = op1 "fail_" -- XXX - to be replaced by Prelude later
op1 "fail_" = \v -> do
    throw <- fromVal =<< readVar (cast "$*FAIL_SHOULD_DIE")
    if throw then op1 "die" (errmsg v) else do
    poss    <- asks envPosStack
    let die = retShift $ VError (errmsg v) poss
        dieThunk = VRef . thunkRef $ MkThunk die (mkType "Failure")
    op1Return (retControl (ControlLeave (<= SubRoutine) 0 dieThunk))
    where
    errmsg VUndef      = VStr "Failed"
    errmsg VType{}     = VStr "Failed"
    errmsg (VStr "")   = VStr "Failed"
    errmsg (VList [])  = VStr "Failed"
    errmsg (VList [x]) = x
    errmsg x           = x
op1 "exit" = op1Exit
op1 "readlink" = \v -> do
    str  <- fromVal v
    guardIO $ fmap VStr (readSymbolicLink str)
op1 "sleep" = \v -> do
    x <- fromVal v :: Eval VNum
    guardIO $ do
        start   <- getCurrentTime
        threadDelay (round $ x * clocksPerSecond)
        finish  <- getCurrentTime
        return $ VRat (toRational $ diffUTCTime start finish)
op1 "mkdir" = guardedIO createDirectory
op1 "rmdir" = guardedIO removeDirectory
op1 "chdir" = guardedIO setCurrentDirectory
op1 "graphs"= op1Cast (VInt . (genericLength :: String -> VInt)) -- XXX Wrong
op1 "codes" = op1Cast (VInt . (genericLength :: String -> VInt))
op1 "chars" = op1Cast (VInt . (genericLength :: String -> VInt))
op1 "bytes" = op1Cast (VInt . (genericLength :: String -> VInt) . encodeUTF8)

op1 "unlink" = \v -> do
    vals <- fromVals v
    rets <- mapM (doBoolIO removeFile) vals
    return $ VInt $ sum $ map bool2n rets
op1 "readdir" = \v -> do
    path  <- fromVal v
    files <- guardIO $ getDirectoryContents path
    retSeq (map VStr files)
op1 "slurp" = \v -> do
    ifValTypeIsa v "IO"
        (do h <- fromVal v
            ifListContext (strictify $! op1 "=" v) $ do
                content <- guardIO $ hGetContents h
                return . VStr $ decodeUTF8 content)
        (do
            fileName    <- fromVal v
            ifListContext
                (slurpList fileName)
                (slurpScalar fileName))
    where
    strictify action = do
        VList lines <- action
        return $ VList (length lines `seq` lines)
    slurpList file = strictify $! op1 "=" (VList [VStr file])
    slurpScalar file = do
        content <- guardIO $ readFile file
        return . VStr $ decodeUTF8 content
op1 "opendir" = \v -> do
    str <- fromVal v
    dir <- guardIO $ openDirStream str
    obj <- createObject (mkType "IO::Dir") []
    return . VObject $ obj{ objOpaque = Just $ toDyn dir }
op1 "IO::Dir::close" = op1 "IO::Dir::closedir"
op1 "IO::Dir::closedir" = guardedIO (closeDirStream . fromObject)
op1 "IO::Dir::rewind" = op1 "IO::Dir::rewinddir"
op1 "IO::Dir::rewinddir" = guardedIO (rewindDirStream . fromObject)
op1 "IO::Dir::read" = op1 "IO::Dir::readdir"
op1 "IO::Dir::readdir" = \v -> do
    dir <- fmap fromObject (fromVal v)
    ifListContext
        (retSeq =<< readDirStreamList dir)
        (guardIO $ fmap (\x -> if null x then undef else castV x) $ readDirStream dir)
    where
    readDirStreamList dir = do
        this <- tryIO "" $ readDirStream dir
        if null this then return [] else do
        rest <- readDirStreamList dir
        return (VStr this:rest)
op1 "Pugs::Internals::runShellCommand" = \v -> do
    str <- fromVal v
    cxt <- asks envContext
    (res, exitCode) <- tryIO ("", ExitFailure (-1)) $ do
        (inp,out,_,pid) <- runInteractiveCommand (encodeUTF8 str)
        hClose inp
        res             <- fmap (decodeUTF8 . deCRLF) $ hGetContents out
        exitCode        <- waitForProcess pid
        return (res, exitCode)
    handleExitCode exitCode 
    return $ case cxt of
        CxtSlurpy{} -> VList (map VStr $ lines res)
        _           -> VStr res
    where
    -- XXX - crude CRLF treatment
    deCRLF []                   = []
    deCRLF ('\r':xs@('\n':_))   = xs
    deCRLF (x:xs)               = (x:deCRLF xs)
op1 "Pugs::Internals::runInteractiveCommand" = \v -> do
    str <- fromVal v
    guardIO $ do
        (inp,out,err,pid) <- runInteractiveCommand str
        return $ VList [ VHandle inp
                       , VHandle out
                       , VHandle err
                       , VProcess (MkProcess pid)
                       ]
op1 "Pugs::Internals::check_for_io_leak" = \v -> do
    rv      <- evalExp (App (Val v) Nothing [])
    leaked  <- fromVal =<< op2Match rv (VType $ mkType "IO")
    when leaked $ do
        fail $ "BEGIN and CHECK blocks may not return IO handles,\n" ++
               "as they would be invalid at runtime."
    return rv
op1 "system" = \v -> do
    cmd         <- fromVal v
    exitCode    <- tryIO (ExitFailure (-1)) $ system (encodeUTF8 cmd)
    handleExitCode exitCode
op1 "accept" = \v -> do
    socket      <- fromVal v
    (h, _, _)   <- guardIO $ accept socket
    return $ VHandle h
op1 "detach" = \v -> do
    case v of
        VThread thr -> do
            stm $ tryPutTMVar (threadLock thr) undef
            return $ VBool True
        _           -> fail $ "Not a thread: " ++ show v
op1 "kill" = \v -> do
    case v of
        VThread thr -> do
            guardIO . killThread $ threadId thr
            return $ VBool True
        _           -> fail $ "Not a thread: " ++ show v
op1 "join" = \v -> do
    case v of
        VThread thr -> stm $ takeTMVar (threadLock thr)
        _           -> op2Join v (VList [])
op1 "async" = \v -> do
    env     <- ask
    code    <- fromVal v
    lock    <- stm $ newEmptyTMVar
    tid     <- guardIO . forkIO $ do -- (if rtsSupportsBoundThreads then forkOS else forkIO) $ do
        val <- runEvalIO env $ do
            enterEvalContext CxtVoid $ App (Val code) Nothing []
        stm $ tryPutTMVar lock val
        return ()
    return . VThread $ MkThread
        { threadId      = tid
        , threadLock    = lock
        }
--WV: async should return the thread id!    return undef
op1 "listen" = \v -> do
    port    <- fromVal v
    socket  <- guardIO $ listenOn (PortNumber $ fromInteger port)
    return $ VSocket socket
op1 "flush" = guardedIO hFlush
op1 "IO::close" = guardedIO hClose
op1 "Socket::close" = guardedIO sClose
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"   = op1Floating log
op1 "log10" = op1Floating (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 "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  <- io $ 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" = op1Cast VV
op1 "stat" = \x -> opPerl5 "require File::stat; File::stat::stat" [x]
op1 "lstat" = \x -> opPerl5 "require File::stat; File::stat::lstat" [x]
op1 "Pugs::Internals::localtime"  = \x -> do
    tz  <- io getCurrentTimeZone
    tm  <- fromVal x    -- seconds since Perl's epoch
    let utc   = posixSecondsToUTCTime (fromInteger tm + offset)
        local = utcToLocalTime tz utc
        day   = localDay local
        tod   = localTimeOfDay local
        (year, month, dayOfMonth)   = toGregorian day 
        (sec, pico)                 = properFraction $ todSec tod
        (_, dayOfWeek)              = sundayStartWeek day
    -- if wantString then return . VStr $ formatTime "%c" (ZonedTime local tz) else
    retSeq [ vI    $ year
           , vI    $ month
           , vI    $ dayOfMonth
           , vI    $ todHour tod
           , vI    $ todMin tod
           , VInt  $ sec
           , vI    $ fromEnum (pico * 1000000000000)
           , vI    $ dayOfWeek + 1
           , vI    $ (monthAndDayToDayOfYear (isLeapYear year) month dayOfMonth) - 1
           , VStr  $ timeZoneName tz
           , vI    $ timeZoneMinutes tz * 60
           , VBool $ timeZoneSummerOnly tz
           ]
    where
    offset :: NominalDiffTime
    offset = 946684800 -- diff between Haskell and Perl epochs (seconds)
    vI :: Integral a => a -> Val
    vI = VInt . toInteger

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 (lookupPad 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
                stm $ writeTVar tvar thunk
                redo
            stm $ 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
            stm $ 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 .
    \str -> case str of
        []      -> []
        (c:cs)  -> (f c:cs)

-- op1Readline and op1Getc are precisely the implementation of op1 "readline"
-- and op1 "getc", but those may be hidden in safe mode. We still want to use
-- the functionality with the safe variants, hence these functions.
op1Readline :: Val -> Eval Val
op1Readline = \v -> op1Read v (io . getLines) getLine
    where
    getLines :: VHandle -> IO Val
    getLines fh = unsafeInterleaveIO $ do
        line <- doGetLine fh
        case line of
            Just str -> do
                ~(VList rest) <- getLines fh
                return $ VList (VStr str:rest)
            _ -> return (VList [])
    getLine :: VHandle -> Eval Val
    getLine fh = do
        line <- io $! doGetLine fh
        case line of
            Just str    -> return $! VStr $! (length str `seq` str)
            _           -> return undef
    doGetLine :: VHandle -> IO (Maybe VStr)
    doGetLine fh = guardIOexcept [(isIOError isEOFError, Nothing)] $ do
        line <- hGetLine fh
        return . Just . decodeUTF8 $ line

isIOError :: (IOError -> Bool) -> Exception -> Bool
isIOError f err = case ioErrors err of
    Just ioe    -> f ioe
    Nothing     -> False

op1Getc :: Val -> Eval Val
op1Getc = \v -> op1Read v (getChar) (getChar)
    where
    getChar :: VHandle -> Eval Val
    getChar fh = guardIOexcept [(isIOError isEOFError, undef)] $ do
        char <- hGetChar fh
        str  <- getChar' fh char
        return $ VStr $ decodeUTF8 str
    -- We may have to read more than one byte, as one utf-8 char can span
    -- multiple bytes.
    getChar' :: VHandle -> Char -> IO String
    getChar' fh char
        | ord char < 0x80 = return [char]
        | ord char < 0xE0 = readNmore 1
        | ord char < 0xEE = readNmore 2
        | ord char < 0xF5 = readNmore 3
        | otherwise       = fail "Invalid utf-8 read by getc()"
        where
        readNmore :: Int -> IO String
        readNmore n = do
            new <- sequence $ replicate n (hGetChar fh)
            return $ char:new

{-|
Read a char or a line from a handle.
-}
op1Read :: Val                   -- ^ The handle to read from (packed in a 'Val')
        -> (VHandle -> Eval Val) -- ^ The function to call in list context
        -> (VHandle -> Eval Val) -- ^ The function to call in item context
        -> Eval Val              -- ^ The return value (a list of strings or a
                                 --   string, packed in a 'Val')
op1Read v fList fScalar = do
    fh  <- handleOf v
    ifListContext
        (fList fh)
        (fScalar fh)
    where
    handleOf x | safeMode, (VHandle h) <- x, h /= stdin = fail "Evil handle detected"
    handleOf _ | safeMode = return stdin
    handleOf VUndef = handleOf (VList [])
    handleOf (VList []) = do
        argsGV  <- readVar (cast "$*ARGS")
        gv      <- fromVal argsGV
        if defined gv
            then handleOf gv
            else do
                args    <- readVar (cast "@*ARGS")
                files   <- fromVal args
                if null files
                    then return stdin
                    else do
                        hdl <- handleOf (VStr (head files)) -- XXX wrong
                        writeVar (cast "$*ARGS") (VHandle hdl)
                        return hdl
    handleOf (VStr x) = do
        return =<< guardIO $ openFile x ReadMode
    handleOf (VList [x]) = handleOf x
    handleOf v = fromVal v

bool2n :: Bool -> VInt
bool2n v = if v
  then 1
  else 0

doBoolIO :: Value a => (a -> IO b) -> Val -> Eval Bool
doBoolIO f v = do
    x <- fromVal v
    tryIO False $ do
        f x
        return True

guardedIO :: Value a => (a -> IO b) -> Val -> Eval Val
guardedIO f v = do
    x <- fromVal v
    guardIO $ f x
    return $ VBool True

guardedIO2 :: (Value a, Value b)
    => (a -> b -> IO c) -> Val -> Val -> Eval Val
guardedIO2 f u v = do
    x <- fromVal u
    y <- fromVal v
    guardIO $ f x y
    return $ VBool True

mapStr :: (Word8 -> Word8) -> [Word8] -> String
mapStr f = map (chr . fromEnum . f)

mapStr2 :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> String
mapStr2 f x y = map (chr . fromEnum . uncurry f) $ x `zip` y

mapStr2Fill :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> String
mapStr2Fill f x y = map (chr . fromEnum . uncurry f) $ x `zipFill` y
    where
    zipFill [] [] = []
    zipFill as [] = zip as (repeat 0)
    zipFill [] bs = zip (repeat 0) bs
    zipFill (a:as) (b:bs) = (a,b) : zipFill as bs

op1Chomp :: VStr -> Val
op1Chomp "" = VStr ""
op1Chomp str
    | last str == '\n'  = VStr (init str)
    | otherwise         = VStr str

perlReplicate :: VInt -> a -> [a]
perlReplicate = genericReplicate . max 0

-- XXX only used at    op2 "?^"   because my Haskell is too poor - ferreira 
neBool :: VBool -> VBool -> VBool
neBool = (==) . not

-- |Implementation of 2-arity primitive operators and functions
op2 :: String -> Val -> Val -> Eval Val
op2 "rename" = guardedIO2 rename
op2 "symlink" = guardedIO2 createSymbolicLink
op2 "link" = guardedIO2 createLink
op2 "*"  = op2Numeric (*)
op2 "/"  = op2Divide
op2 "%"  = op2Modulus
op2 "x"  = op2Cast (\x y -> VStr . concat $ (y :: VInt) `perlReplicate` x)
op2 "xx" = op2Cast (\x y -> VList . concat $ (y :: VInt) `perlReplicate` x)
op2 "+&" = op2Int (.&.)
op2 "+<" = op2Int shiftL
op2 "+>" = op2Int shiftR
op2 "~&" = op2Str $ mapStr2 (.&.)
op2 "~<" = op2Cast (\x y -> VStr $ mapStr (`shiftL` y) x)
op2 "~>" = op2Cast (\x y -> VStr $ mapStr (`shiftR` y) x)
op2 "**" = op2Exp
op2 "+"  = op2Numeric (+)
op2 "-"  = op2Numeric (-)
op2 "atan" = op2Num atan2
op2 "~"  = op2Str (++)
op2 "+|" = op2Int (.|.)
op2 "+^" = op2Int xor
op2 "~|" = op2Str $ mapStr2Fill (.|.)
op2 "?|" = op2Bool (||)
op2 "?&" = op2Bool (&&)
op2 "~^" = op2Str $ mapStr2Fill xor
op2 "?^" = op2Bool neBool -- for bools, 'xor' is the same as '!=='
op2 "=>" = \x y -> return $ castV (x, y)
op2 "="  = \x y -> evalExp (Syn "=" [Val x, Val y])
op2 "cmp"= op2OrdNumStr
op2 "leg"= op2Ord vCastStr
op2 "<=>"= op2OrdNumeric compare
op2 ".." = op2Range
op2 "..^" = op2RangeExclRight
op2 "^.." = op2RangeExclLeft
op2 "^..^" = op2RangeExclBoth
op2 "!=" = op2OrdNumeric (/=)
op2 "==" = op2OrdNumeric (==)
op2 "<"  = op2OrdNumeric (<)
op2 "<=" = op2OrdNumeric (<=)
op2 ">"  = op2OrdNumeric (>)
op2 ">=" = op2OrdNumeric (>=)
op2 "ne" = op2Cmp vCastStr (/=)
op2 "eq" = op2Cmp vCastStr (==)
op2 "lt" = op2Cmp vCastStr (<)
op2 "le" = op2Cmp vCastStr (<=)
op2 "gt" = op2Cmp vCastStr (>)
op2 "ge" = op2Cmp vCastStr (>=)
op2 "~~" = op2Match
op2 "=:=" = \x y -> do
    return $ castV $ case x of
        VRef xr | VRef yr <- y ->
            -- Take advantage of the pointer address built-in with (Show VRef)
            show xr == show yr
        _   ->
            W# (unsafeCoerce# x :: Word#) == W# (unsafeCoerce# y :: Word#)
op2 "===" = \x y -> do
    return $ castV (x == y)
op2 "eqv" = op2Identity -- XXX wrong, needs to compare full objects
op2 "&&" = op2Logical (fmap not . fromVal)
op2 "||" = op2Logical (fmap id . fromVal)
op2 "^^" = \x y -> do
    let xor True True   = VBool False
        xor True False  = x
        xor False True  = y
        xor False False = VBool False
    op2Cast xor x y
op2 "//" = op2Logical (return . defined)
op2 ".[]" = \x y -> do
    evl <- asks envEval
    evl $ Syn "[]" [Val x, Val y]
op2 ".{}" = \x y -> do
    evl <- asks envEval
    evl $ Syn "{}" [Val x, Val y]
-- XXX pipe forward XXX
op2 "and"= op2 "&&"
op2 "or" = op2 "||"
op2 "xor"= op2 "^^"
op2 "orelse"= op2 "//"  -- XXX wrong
op2 "andthen"= op2 "&&" -- XXX even wronger
op2 "pick" = op2Pick
op2 "grep" = op2Grep
op2 "first" = op2First
op2 "map"  = op2Map
op2 "join" = op2Join
op2 "reduce" = op2ReduceL False
op2 "produce" = op2ReduceL True
op2 "reverse" = op2MaybeListop (VList . reverse) (VStr . reverse)
op2 "chomp" = op2MaybeListop (VList . map op1Chomp) op1Chomp
op2 "kill" = \s v -> do
    sig  <- fromVal s
    pids <- fromVals v
    sig' <- fromVal sig
    pids'<- mapM fromVal pids
    let doKill pid = do
        signalProcess (toEnum sig') (toEnum pid)
        return 1
    rets <- mapM (tryIO 0 . doKill) pids'
    return . VInt $ sum rets
op2 "isa"    = \x y -> do
    typY <- case y of
        VStr str -> return $ mkType str
        _        -> fromVal y
    typX <- fromVal x -- XXX consider line 224 of Pugs.Prim.Match case too
    typs <- pkgParentClasses (showType typX)
    return . VBool $ showType typY `elem` (showType typX:typs)
op2 "does"   = \x y -> do
    typY <- case y of
        VStr str -> return $ mkType str
        _        -> fromVal y
    op2Match x (VType typY)
op2 "delete" = \x y -> do
    ref <- fromVal x
    rv  <- deleteFromRef ref y
    -- S29: delete always returns the full list regardless of context.
    return $ case rv of
        VList [x]   -> x
        _           -> rv
op2 "exists" = \x y -> do
    ref <- fromVal x
    fmap VBool (existsFromRef ref y)
op2 "unshift" = op2Array array_unshift
op2 "push" = op2Array array_push
op2 "split" = op2Split
op2 "Str::split" = flip op2Split
op2 "connect" = \x y -> do
    host <- fromVal x
    port <- fromVal y
    hdl  <- guardIO $ connectTo host (PortNumber $ fromInteger port)
    return $ VHandle hdl
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