{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-warn-deprecations -fallow-overlapping-instances #-}

{-|
    Evaluation and reduction engine.

>   Home is behind, the world ahead,
>   And there are many paths to tread
>   Through shadows to the edge of night,
>   Until the stars are all alight.
>   Then world behind and home ahead,
>   We'll wander back to home and bed...

This module takes an /abstract syntax tree/ and recursively evaluates it,
thereby evaluating the program.

The AST is represented as a hierarchy of nested 'Exp' expressions
(see "Pugs.AST").  Some understanding of 'Exp' and "Pugs.AST" in will help in
understanding this module.
-}

module Pugs.Eval (
    evaluate,
    emptyEnv, evaluateMain,
    enterLValue, enterRValue,
    runWarn
) where
import Pugs.Internals
import Prelude hiding ( exp )
import qualified Data.Map as Map

import Pugs.AST
import Pugs.Junc
import Pugs.Bind
import Pugs.Prim
import Pugs.Prim.List (op0Zip, op0Cat, op0Each, op0RoundRobin)
import Pugs.Monads
import Pugs.Pretty
import Pugs.Types
import Pugs.External
import Pugs.Eval.Var
import DrIFT.YAML ()
import qualified Data.ByteString.Char8 as Buf


{-|
Construct a new, \'empty\' 'Env' (evaluation environment).

See the source of 'Pugs.Prims.initSyms' for a list of symbols that are
initially present in the global 'Pad'.
-}
emptyEnv :: (MonadIO m, MonadSTM m) 
         => String             -- ^ Name associated with the environment
         -> [STM PadMutator]   -- ^ List of 'Pad'-mutating transactions used
                               --     to declare an initial set of global
                               --     variables
         -> m Env
emptyEnv name genPad = liftSTM $ do
    pad  <- sequence genPad
    ref  <- newTVar Map.empty
    syms <- initSyms
    let globPad = combine (pad ++ syms) $ mkPad []
    glob <- newTVar globPad
    init <- newTVar $ MkInitDat { initPragmas=[] }
    maxi <- newTVar $ MkObjectId 1
    return $ MkEnv
        { envContext = CxtVoid
        , envLexical = mkPad []
        , envImplicit= Map.empty
        , envLValue  = False
        , envGlobal  = length (show (padKeys globPad)) `seq` glob -- force eval of all sym names
        , envPackage = cast "Main"
        , envClasses = initTree
        , envEval    = evaluate
        , envCaller  = Nothing
        , envOuter   = Nothing
        , envFrames  = emptyFrames
        , envBody    = Val undef
        , envDebug   = Just ref -- Set to "Nothing" to disable debugging
        , envPos     = MkPos name 1 1 1 1
        , envPragmas = []
        , envInitDat = init
        , envMaxId   = maxi
        , envAtomic  = False
        }

-- Evaluation ---------------------------------------------------------------

{-|
Emits a runtime warning.
-}
-- XXX: This should cache so that you don't warn in the same place twice
--   (even though Perl 5 doesn't do this).
--   It should also respond to lexical warnings pragmata.
runWarn :: String -> Eval ()
runWarn msg = do 
    enterEvalContext CxtVoid $
        App (_Var "&warn") Nothing [Val (VStr msg)]
    return ()

type DebugCache = TVar (Map ID String)

{-# SPECIALIZE debug :: DebugCache -> ID -> (String -> String) -> String -> String -> Eval () #-}
debug :: Pretty a => DebugCache -> ID -> (String -> String) -> String -> a -> Eval ()
debug ref key fun str a = do
    val <- liftSTM $ do
        fm <- readTVar ref
        let val = fun $ Map.findWithDefault "" key fm
        writeTVar ref (Map.insert key val fm)
        return val
    when (length val > 100) $ do
        liftIO $ putStrLn "*** Warning: deep recursion"
    liftIO $ putStrLn ("***" ++ val ++ str ++ encodeUTF8 (pretty a))

evaluateMain :: Exp -> Eval Val
evaluateMain exp = do
    -- S04: INIT {...}*      at run time, ASAP
    initAV   <- reduceVar $ cast "@*INIT"
    initSubs <- fromVals initAV
    enterContext CxtVoid $ do
        mapM_ evalExp [ App (Val sub) Nothing [] | sub@VCode{} <- initSubs ]
    evalExp (Syn "=" [_Var "@*INIT", Syn "," []])
    -- The main runtime
    tryT (evaluate exp) `finallyM` do
        -- S04: END {...}       at run time, ALAP
        endAV       <- reduceVar $ cast "@*END"
        endSubs     <- fromVals endAV
        endMainAV   <- reduceVar $ cast "@Main::END"
        endMainSubs <- fromVals endMainAV
        enterContext CxtVoid $ do
            mapM_ evalExp [ App (Val sub) Nothing [] | sub@VCode{} <- endMainSubs ++ endSubs ]

{-|
Evaluate an expression.

This function mostly just delegates to 'reduce'.
-}
evaluate :: Exp -- ^ The expression to evaluate
         -> Eval Val
evaluate (Val val) = evalVal val
evaluate exp = do
    debugRef <- asks envDebug
    case debugRef of
        Just ref -> do
            want <- asks envWant
            debug ref (cast "indent") ('-':) (" Evl [" ++ want ++ "]:\n") exp
            val <- local (\e -> e{ envBody = exp }) $ reduce exp
            debug ref (cast "indent") (\x -> if null x then [] else tail x) "- Ret: " val
            trapVal val (return val)
        Nothing -> do
            val <- reduce exp
            trapVal val (return val)

-- Reduction ---------------------------------------------------------------

retVal :: Val -> Eval Val
retVal val = evaluate (Val val)

retItem :: Val -> Eval Val
retItem val = do
    ifListContext
        (retVal $ VList [val])
        (retVal $ val)

{-|
Add a symbol to the global 'Pad'.

Used by 'reduceSym'.
-}
addGlobalSym :: PadMutator -- ^ 'Pad'-transformer that will insert the new
                           --     symbol
             -> Eval ()
addGlobalSym newSym = do
    glob <- asks envGlobal
    liftSTM $ do
        syms <- readTVar glob
        writeTVar glob (newSym syms)

trapVal :: Val -> Eval a -> Eval a
trapVal val action = case val of
    VError str posList -> do
        pos <- asks envPos
        retShift $ VError str (pos:posList)
    VControl c      -> retControl c
    _               -> action

evalRef :: VRef -> Eval Val
evalRef ref = do
    if refType ref == (mkType "Thunk") then forceRef ref else do
    val <- catchT $ \esc -> do
        MkEnv{ envContext = cxt, envLValue = lv, envClasses = cls } <- ask
        let typ = typeOfCxt cxt
            isCollectionRef = isaType cls "List" (refType ref)
        -- If RValue, read from the reference
        unless lv $ do
            when (isCollectionRef && isItemCxt cxt) $ do
                -- auto-enreference
                esc $ VRef ref
            case ref of
                MkRef IPair{}   -> esc (VRef ref)
                _               -> esc =<< readRef ref
        -- LValue here
        when isCollectionRef $ esc (castV ref)
        val <- readRef ref
        let isAutovivify = and $
                [ isItemCxt cxt
                , isUndefinedVal val
                , (typ ==) `any` [mkType "Array", mkType "Hash"]
                ]
            isUndefinedVal VUndef   = True
            isUndefinedVal VType{}  = True
            isUndefinedVal _        = False
            -- Here we ensutre "my Hash $x" can only vivify into Hash no matter how it's asked.
            typ' = case val of
                VType t -> t
                _       -> typ 
        when isAutovivify $ do
            ref' <- newObject typ'
            writeRef ref (VRef ref')
        return $ castV ref
    retVal val

{-|
Reduce an expression into its value.

This function dispatches to the relevant @reduce*@ function for the type of
expression given.
-}
reduce :: Exp -- ^ The expression to reduce
       -> Eval Val

reduce (Val v) = reduceVal v

reduce (Var name) = reduceVar name

reduce (Stmts this rest) = reduceStmts this rest

reduce (Ann (Prag prag) exp) = reducePrag prag exp

reduce (Ann (Pos pos) exp) = reducePos pos exp

reduce (Ann (Cxt cxt) exp) = reduceCxt cxt exp

reduce (Ann _ exp) = reduce exp

reduce (Pad scope lexEnv exp) = reducePad scope lexEnv exp

reduce (Sym scope name exp) = reduceSym scope name exp

-- Reduction for no-operations
reduce Noop = retEmpty

reduce (Syn name subExps) = reduceSyn name subExps

reduce (App subExp inv args) = reduceApp subExp inv args

reduce exp = retError "Invalid expression" exp

reduceVal :: Val -> Eval Val
reduceVal v@(VRef (MkRef IPair{})) = return v

-- Reduction for mutables
reduceVal v@(VRef var) = do
    lv <- asks envLValue
    if lv then retVal v else do
    rv <- readRef var
    retVal rv

-- Reduction for constants
reduceVal v = retVal v

-- Reduction for variables
reduceVar :: Var -> Eval Val
reduceVar var@MkVar{ v_sigil = sig, v_twigil = twi, v_name = name, v_package = pkg }
    | TAttribute <- twi
    = reduceSyn (show sig ++ "{}") [ Syn "{}" [_Var "&self", Val (VStr $ cast name)] ]
    | TPrivate <- twi
    = reduceSyn (show sig ++ "{}") [ Syn "{}" [_Var "&self", Val (VStr $ cast name)] ]
    | otherwise = do
        v <- findVar var
        case v of
            Just ref -> evalRef ref
            Nothing
                | SType <- sig      -> return . VType . cast $ if isQualifiedVar var
                    then cast $ Buf.join (__"::") [cast pkg, cast name]
                    else name
                | isGlobalVar var || pkg `notElem` [emptyPkg, callerPkg, outerPkg, contextPkg] -> do
                    -- $Qualified::Var is not found.  Vivify at lvalue context.
                    lv <- asks envLValue
                    if lv then evalExp (Sym SGlobal var (Var var)) else retEmpty
                | otherwise         -> retError "Undeclared variable" var

_scalarContext :: Cxt
_scalarContext = CxtItem $ mkType "Scalar"

reduceStmts :: Exp -> Exp -> Eval Val
reduceStmts Noop rest           = reduce rest
reduceStmts (Ann _ Noop) rest   = reduce rest
reduceStmts this Noop           = reduce this
reduceStmts this (Ann _ Noop)   = reduce this

-- XXX - Hack to get context propagating to "return"
reduceStmts this@(App (Var var) _ _) _ | var == cast "&return" = reduce this
reduceStmts this@(Ann _ (App (Var var) _ _)) _ | var == cast "&return" = reduce this

reduceStmts this rest = do
    let withCxt = case this of
            App (Var var) _ _         | var == cast "&yield" -> id
            Ann _ (App (Var var) _ _) | var == cast "&yield" -> id
            _  -> enterContext cxtVoid
    val <- withCxt (reduce this)
    trapVal val $ case rest of
        Syn "continuation" []   -> callCC $ \cc -> do
            env <- ask
            return . VControl $ ControlContinuation env val cc
        _                       -> reduce rest

reducePrag :: [Pragma] -> Exp -> Eval Val
reducePrag prag exp = do
    local (\e -> e{ envPragmas = prag }) $ do
        evalExp exp

{-|
Reduce a 'Pos' expression by reducing its subexpression in a new 'Env', which
holds the 'Pos'\'s position.
-}
reducePos :: Pos -> Exp -> Eval Val
reducePos pos exp = do
    local (\e -> e{ envPos = pos }) $ do
        evalExp exp

reducePad :: Scope -> Pad -> Exp -> Eval Val
reducePad SEnv lex@(MkPad lex') exp = do
    local (\e -> e{ envImplicit = Map.map (const ()) lex' `Map.union` envImplicit e }) $
        reducePad SMy lex exp
reducePad SMy lex exp = do
    -- heuristics: if we are repeating ourselves, generate a new TVar.
    lex' <- refreshPad lex
    local (\e -> e{ envLexical = lex' `unionPads` envLexical e }) $ do
        evalExp exp

reducePad STemp lex exp = do
    tmps <- mapM (\(sym, _) -> evalExp $ App (_Var "&TEMP") (Just $ Var sym) []) $ padToList lex
    -- default to nonlocal exit
    isNonLocal  <- liftSTM $ newTVar True
    val <- tryT $ do
        -- if the liftSTM is reached, exp evaluated without error; no need to shift out
        evalExp exp `finallyM` liftSTM (writeTVar isNonLocal False)
    mapM_ (\tmp -> evalExp $ App (Val tmp) Nothing []) tmps
    isn <- liftSTM $ readTVar isNonLocal
    (if isn then retShift else return) val

reducePad _ lex exp = do
    local (\e -> e{ envLexical = lex `unionPads` envLexical e }) $ do
        evalExp exp
        
reduceSym :: Scope -> Var -> Exp -> Eval Val
-- Special case: my (undef) is no-op
reduceSym scope var exp
--  | var == cast "" = evalExp exp
    | scope <= SMy = do
        ref <- newObject (typeOfSigilVar var)
        let (gen, var')
                | SCodeMulti <- v_sigil var
                = (genMultiSym, var{ v_sigil = SCode })
                | otherwise
                = (genSym, var)
        sym <- gen var' ref
        enterLex [ sym ] $ evalExp exp
    | otherwise = do
        ref <- newObject (typeOfSigilVar var)
        let (gen, var')
                | SCodeMulti <- v_sigil var
                = (genMultiSym, var{ v_sigil = SCode })
                | otherwise
                = (genSym, var)
        qn      <- toQualified var'
        sym     <- gen qn ref
        addGlobalSym sym
        evalExp exp

-- Context forcing
reduceCxt :: Cxt -> Exp -> Eval Val
reduceCxt cxt exp = do
    val <- enterEvalContext cxt exp
    enterEvalContext cxt (Val val) -- force casting

{-|
Reduce a 'Syn' expression, i.e. a syntactic construct that cannot (yet) be
expressed using 'App' (regular sub application).

Theoretically, 'Syn' will one day be deprecated when 'App' becomes powerful
enough to make it redundant.
-}
reduceSyn :: String -> [Exp] -> Eval Val

reduceSyn "()" [exp] = reduce exp

reduceSyn "named" [keyExp, valExp] = do
    key <- enterEvalContext cxtItemAny keyExp
    val <- enterEvalContext cxtItemAny valExp
    retItem $ castV (key, val)

reduceSyn "continuation" [] = callCC $ \cc -> do
    env <- ask
    return . VControl $ ControlContinuation env undef cc

reduceSyn "block" [exp]
    | Syn "sub" [Val (VCode sub@MkCode{ subType = SubBlock })] <- unwrap exp = do
        unless (isEmptyParams (subParams sub)) $
            fail "Blocks with implicit params cannot occur at statement level"
        env <- ask
        enterSub (sub{ subEnv = Just env }) . reduce $ case unwrap (subBody sub) of
            Syn "block" [exp] -> case unwrap exp of
                -- Here we have a nested statement-level block: "{ { 3 } }";
                -- we actually want to create two OUTER blocks, so reduce normally.
                Syn "sub" [Val (VCode MkCode{ subType = SubBlock })] -> subBody sub
                _   -> exp
            _                   -> subBody sub
    | otherwise = enterBlock $ reduce exp
    
reduceSyn "sub" [exp] = do
    (VCode sub) <- enterEvalContext (cxtItem "Code") exp
    env  <- ask
    cont <- if subType sub /= SubCoroutine then return Nothing else liftSTM $ do
        tvar <- newTVar (error "empty sub")
        let thunk = (`MkThunk` anyType) . fix $ \redo -> do
            evalExp $ subBody sub
            liftSTM $ writeTVar tvar thunk
            redo
        writeTVar tvar thunk
        return $ Just tvar
    newBody <- transformExp cloneBodyStates $ subBody sub
    retVal $ VCode sub
        { subEnv  = Just env
        , subCont = cont
        , subBody = newBody
        }
    where
    cloneBodyStates (Pad scope pad exp) | scope <= SMy = do
        pad' <- clonePad pad
        return $ Pad scope pad' exp
    cloneBodyStates x = return x
    clonePad pad = do
        fmap listToPad $ forM (padToList pad) $ \(var, tvars) -> do
            tvars' <- forM tvars $ \(_, tvar) -> do
                fresh'  <- liftSTM $ newTVar False
                tvar'   <- (liftSTM . newTVar) =<< case v_sigil var of
                    SType       -> liftSTM $ readTVar tvar
                    SCode       -> liftSTM $ readTVar tvar
                    SCodeMulti  -> liftSTM $ readTVar tvar
                    _           -> newObject (typeOfSigilVar var)
                return (fresh', tvar')
            return (var, tvars')

reduceSyn "but" [obj, block] = do
    evalExp $ App (_Var "&Pugs::Internals::but_block") Nothing [obj, block]

reduceSyn name [cond, bodyIf, bodyElse]
    | "if"     <- name = doCond id
    | "unless" <- name = doCond not
    where
    doCond :: (Bool -> Bool) -> Eval Val
    doCond f = do
        vbool     <- enterRValue $ enterEvalContext (cxtItem "Bool") cond
        vb        <- fromVal vbool
        if (f vb)
            then reduce bodyIf
            else reduce bodyElse

reduceSyn "for" [list, body] = enterLoop $ do
    av    <- enterLValue $ enterEvalContext cxtSlurpyAny list
    sub   <- fromCodeExp body
    -- XXX this is wrong -- should use Array.next
    elms  <- case av of
        VRef (MkRef sv@IScalar{})   -> return [sv]
        VList xs                    -> return . (`map` xs) $ \x -> case x of
            VRef (MkRef sv@IScalar{})   -> sv
            _                           -> (IScalar x)
        _                           -> join $ doArray av array_fetchElemAll
    -- This makes "for @x { ... }" into "for @x -> $_ is rw {...}"
    let arity = max 1 $ length (subParams sub)
        runBody [] _ _ = retVal undef
        runBody vs sub' isFirst = do
            let (these, rest) = arity `splitAt` vs
                realSub
                    = (`afterLeave` if null rest then subLastBlocks else const [])
                    . (`beforeLeave` subNextBlocks)
                    $ if isFirst then sub' `beforeEnter` subFirstBlocks else sub'
            rv <- apply realSub Nothing $ map (Val . VRef . MkRef) these
            case rv of
                VControl (ControlLoop LoopRedo) -> runBody vs sub' isFirst
                VControl (ControlLoop LoopLast) -> retVal undef
                _                               -> runBody rest sub' False
    runBody elms sub True

reduceSyn "gather" [exp] = do
    sub     <- fromVal =<< evalExp exp
    globTV  <- asks envGlobal
    glob    <- liftSTM $ readTVar globTV
    oldAV   <- findSymRef takeVar glob
    oldSym  <- genSym takeVar oldAV
    newAV   <- newObject (mkType "Array")
    newSym  <- genSym takeVar newAV
    liftSTM $ writeTVar globTV (newSym glob)
    enterGather $ apply sub Nothing []
    readRef newAV `finallyM` liftSTM (modifyTVar globTV oldSym)
    where
    takeVar = cast "$*TAKE"

reduceSyn "loop" exps = enterLoop $ do
    let [pre, cond, post, body] = case exps of { [_] -> exps'; _ -> exps }
        exps' = [emptyExp, Val (VBool True), emptyExp] ++ exps
        evalCond | unwrap cond == Noop = return True
                 | otherwise = fromVal =<< enterEvalContext (cxtItem "Bool") cond
    sub     <- fromCodeExp body
    evalExp pre
    vb      <- evalCond
    if not vb then retEmpty else fix $ \runBody -> do
        valBody <- apply (sub `beforeLeave` subNextBlocks) Nothing []
        let runNext = do
                valPost <- evalExp post
                vb      <- evalCond
                trapVal valPost $ if vb then runBody else retEmpty
        case valBody of
            VControl (ControlLoop LoopRedo) -> runBody
            VControl (ControlLoop LoopLast) -> retEmpty
            VControl (ControlLoop LoopNext) -> runNext
            _                               -> trapVal valBody runNext

reduceSyn "given" [topic, body] = enterGiven $ do
    sub     <- fromCodeExp body
    apply sub Nothing [App (_Var "&VAR") (Just topic) []]

reduceSyn "when" [match, body] = do
    result  <- reduce $ case unwrap match of
        App _ (Just (Var var)) _    | var == varTopic -> match
        Syn _ [Var var, _]          | var == varTopic -> match
        _ -> App (_Var "&*infix:~~") Nothing [Var varTopic, match]
    rb      <- fromVal result
    if not rb then retEmpty else do
        sub     <- fromCodeExp body
        enterWhen $ apply sub Nothing []

reduceSyn "default" [body] = do
    sub     <- fromCodeExp body
    enterWhen $ apply sub Nothing []

reduceSyn name [cond, body]
    | "while" <- name = doWhileUntil id False
    | "until" <- name = doWhileUntil not False
    | "postwhile" <- name = doWhileUntil id True
    | "postuntil" <- name = doWhileUntil not True
    where
    -- XXX The "first" loop should be merged into the normal runloop
    doWhileUntil :: (Bool -> Bool) -> Bool -> Eval Val
    doWhileUntil f postloop = enterLoop $ do
        origSub <- fromVal =<< (enterRValue $ enterEvalContext (cxtItem "Code") body)
        let sub = origSub `beforeLeave` subNextBlocks
        rv  <- if not postloop then retEmpty else fix $ \runBody -> do
            rv <- apply sub Nothing [Val $ castV undef]
            case rv of
                VControl (ControlLoop LoopRedo) -> runBody
                _                               -> return rv
        case rv of
            VError{}                        -> retVal rv
            VControl (ControlLoop LoopLast) -> retEmpty
            _                               -> do
                ($ rv) . fix $ \runLoop prev -> do
                    vbool <- enterEvalContext (cxtItem "Bool") cond
                    vb    <- fromVal vbool
                    if f vb
                        then fix $ \runBody -> do
                            rv <- apply sub Nothing [Val vbool]
                            case rv of
                                VControl (ControlLoop LoopRedo) -> runBody
                                VControl (ControlLoop LoopLast) -> retVal prev
                                VError{}    -> retVal rv
                                _           -> runLoop prev
                        else case prev of
                            VControl ControlLoop{}  -> retEmpty
                            _                       -> retVal rv

reduceSyn "=" [lhs, rhs] = do
    refVal  <- enterLValue $ evalExp lhs
    ref     <- fromVal refVal
    cls     <- asks envClasses
    let typ = refType ref
        cxt | isaType cls "List" typ = cxtSlurpyAny
            | otherwise = cxtItem $ takeWhile (/= ':') . show $ refType ref
    val <- enterRValue $ enterEvalContext cxt rhs
    writeRef ref val
    lv      <- asks envLValue
    if lv then retVal refVal else
        ifListContext (readRef ref) $
            if cxt == cxtSlurpyAny
                then retVal refVal
                else readRef ref

reduceSyn "::=" exps = reduce (Syn ":=" exps)

reduceSyn ":=" exps
    | [Syn "," vars, Syn "," vexps] <- unwrap exps = do
        when (length vars > length vexps) $ do
            fail $ "Wrong number of binding parameters: "
                ++ (show $ length vexps) ++ " actual, "
                ++ (show $ length vars) ++ " expected"
        -- env' <- cloneEnv env -- FULL THUNKING
        names <- forM vars $ \var -> case unwrap var of
            Var name -> return name
            Syn [sigil,':',':','(',')'] [vexp]
                | Val (VStr name) <- unwrap vexp -> return $ possiblyFixOperatorName (cast (sigil:name))
            _        -> retError "Cannot bind this as lhs" var
        bindings <- forM (names `zip` vexps) $ \(var, vexp) -> enterLValue $ do
            {- FULL THUNKING
            let ref = thunkRef . MkThunk $ do
                    local (const env'{ envLValue = True }) $ do
                        enterEvalContext (cxtOfSigil $ head name) vexp
            -}
            val  <- enterEvalContext (cxtOfSigilVar var) vexp
            ref  <- fromVal val
            rv   <- findVarRef var
            case rv of
                Just tvar -> return (tvar, ref)
                _ | isGlobalVar var || v_package var `notElem` [emptyPkg, callerPkg, outerPkg, contextPkg] -> do
                    -- $Qualified::Var is not found.  Vivify at lvalue context.
                    evalExp (Sym SGlobal var Noop)
                    rv' <- findVarRef var
                    case rv' of
                        Just tvar   -> return (tvar, ref)
                        _           -> retError "Bind to undeclared variable" var
                _   -> retError "Bind to undeclared variable" var
        forM_ bindings $ \(tvar, ref) -> do
            liftSTM $ writeTVar tvar ref
        return $ case map (VRef . snd) bindings of
            [v] -> v
            vs  -> VList vs

reduceSyn ":=" [var, vexp] = do
    let expand e | e'@(Syn "," _) <- unwrap e = e'
        expand e = Syn "," [e]
    reduce (Syn ":=" [expand var, expand vexp])

reduceSyn "*" [] = return (VNum (1/0))

{-
reduceSyn "[,]" [exp] = do
    val <- enterRValue $ enterEvalContext cxtSlurpyAny exp
    return . VList =<< fromVal val
    -- vals <- fromVals val
    -- return $ VList $ concat vals
-}

reduceSyn "," exps = do
    vals <- mapM (enterEvalContext cxtSlurpyAny) exps
    retVal . VList . concat $ map castList vals
    where
    castList (VList vs) = vs
    castList v = [v]

reduceSyn "val" [exp] = do
    enterRValue $ evalExp exp

reduceSyn "\\{}" [exp] = do
    v   <- enterRValue . enterBlock $ enterEvalContext cxtSlurpyAny exp
    hv  <- newObject (mkType "Hash")
    writeRef hv v
    retVal $ VRef hv

reduceSyn "\\[]" [exp] = do
    v   <- enterRValue $ enterEvalContext cxtSlurpyAny exp
    av  <- newObject (mkType "Array")
    writeRef av v
    retItem $ VRef av

reduceSyn "[]" exps
    -- XXX evil hack for infinite slices
    | [lhs, App (Var var) invs args] <- unwrap exps
    , var == cast "&postfix:..."
    , [idx] <- maybeToList invs ++ args
--  , not (envLValue env)
    = reduce (Syn "[...]" [lhs, idx])
    | [lhs, App (Var var) invs args] <- unwrap exps
    , var == cast "&infix:.."
    , [idx, Val (VNum n)] <- maybeToList invs ++ args
    , n == 1/0
--  , not (envLValue env)
    = reduce (Syn "[...]" [lhs, idx])
    | otherwise = do
        let [listExp, indexExp] = exps
        varVal  <- enterLValue $ enterEvalContext (cxtItem "Array") listExp
        idxCxt  <- inferExpCxt indexExp 
        idxVal  <- enterRValue $ enterEvalContext idxCxt indexExp
        lv      <- asks envLValue
        doFetch (mkFetch $ doArray varVal array_fetchElem)
                (mkFetch $ doArray varVal array_fetchVal)
                (fromVal idxVal) lv $ case idxVal of
                    VList {} -> False
                    _        -> True

reduceSyn "[...]" [listExp, indexExp] = do
    idxVal  <- enterRValue $ enterEvalContext (cxtItem "Int") indexExp
    idx     <- fromVal idxVal
    listVal <- enterRValue $ enterEvalContext cxtSlurpyAny listExp
    list    <- fromVal listVal
    -- elms    <- mapM fromVal list -- flatten
    retVal $ VList (drop idx $ list)

-- XXX - Wrong!
reduceSyn "|" [exp] = evalExp exp

reduceSyn "@{}" [exp] = do
    val     <- enterEvalContext (cxtItem "Array") exp
    ivar    <- doArray val IArray
    evalRef (MkRef ivar)

reduceSyn "%{}" [exp] = do
    val     <- enterEvalContext (cxtItem "Hash") exp
    ivar    <- doHash val IHash
    evalRef (MkRef ivar)

reduceSyn "&{}" [exp] = do
    val     <- enterEvalContext (cxtItem "Code") exp
    sub     <- fromVal val
    return $ VCode sub

reduceSyn "${}" [exp] = do
    val     <- enterEvalContext (cxtItem "Scalar") exp
    ref     <- fromVal val
    evalRef ref

reduceSyn (sigil:"::()") exps = do
    -- These are all parts of the name
    parts   <- mapM fromVal =<< mapM evalExp exps
    -- Now we only have to add the sigil in front of the string and join
    -- the parts with "::".
    let varname = sigil:(concat . (intersperse "::") $ parts)
    -- Finally, eval the varname.
    reduceVar (possiblyFixOperatorName (cast varname))

reduceSyn "{}" [listExp, indexExp] = do
    varVal  <- enterLValue $ enterEvalContext (cxtItem "Hash") listExp
    idxCxt  <- inferExpCxt indexExp 
    idxVal  <- enterRValue $ enterEvalContext idxCxt indexExp
    lv      <- asks envLValue
    doFetch (mkFetch $ doHash varVal hash_fetchElem)
        (mkFetch $ doHash varVal hash_fetchVal)
        (fromVal idxVal) lv $ case idxVal of
            VList {} -> False
            _        -> True

reduceSyn "rx" [exp, adverbs] = do
    hv      <- fromVal =<< evalExp adverbs
    val     <- enterEvalContext (cxtItem "Str") exp
    str     <- fromVal val
    p5      <- fromAdverb hv ["P5", "Perl5", "perl5"]
    p5flags <- fromAdverb hv ["P5", "Perl5", "perl5"]
    flag_g  <- fromAdverb hv ["g", "global"]
    flag_i  <- fromAdverb hv ["i", "ignorecase"]
    flag_s  <- fromAdverb hv ["s", "sigspace"]
    flag_r  <- fromAdverb hv ["ratchet"]
    flag_tilde  <- fromAdverb hv ["stringify"] -- XXX hack
    adverbHash  <- reduce adverbs
    let g = ('g' `elem` p5flags || flag_g)
        p5re = mkRegexWithPCRE (encodeUTF8 str) $
                    [ pcreUtf8
                    , ('i' `elem` p5flags || flag_i) `implies` pcreCaseless
                    , ('m' `elem` p5flags) `implies` pcreMultiline
                    , ('s' `elem` p5flags) `implies` pcreDotall
                    , ('x' `elem` p5flags) `implies` pcreExtended
                    ]
        p6re = combine
            [ if flag_s then (\x -> ":sigspace(1)[" ++ x ++ "]") else id
            , if flag_r then (\x -> ":ratchet(1)[" ++ x ++ "]") else id
            ] str
        {-
        p6re | null p6reAdvs = str
             | ':':_ <- str  = p6reAdvs ++ str
             | otherwise     = p6reAdvs ++ "::" ++ str
        -}
        rx | p5 = do ns <- liftIO $ numSubs p5re
                     return $ MkRulePCRE p5re g ns flag_tilde str adverbHash
           | otherwise = return $ MkRulePGE p6re g flag_tilde adverbHash
    retVal . VRule =<< rx
    where
    implies True  = id
    implies False = const 0
    fromAdverb _ [] = fromVal undef
    fromAdverb hv (k:ks) = case lookup k hv of
        Just v  -> fromVal v
        Nothing -> fromAdverb hv ks

reduceSyn "//" exps = reduceSyn "match" exps -- XXX - this is wrong

reduceSyn "match" exps = do
    immediate <- isImmediateMatchContext
    if immediate
        then reduceApp (_Var "&infix:~~") Nothing [Var varTopic, Syn "rx" exps]
        else reduceSyn "rx" exps

reduceSyn "subst" [exp, subst, adverbs] = do
    (VRule rx)  <- reduce (Syn "rx" [exp, adverbs])
    retVal $ VSubst (MkSubst rx subst)

reduceSyn "trans" (fromExp:toExp:_) = do
    from <- fromVal =<< reduce fromExp
    to   <- fromVal =<< reduce toExp
    retVal $ VSubst (MkTrans from to)

-- XXX - Runtime mixin
reduceSyn "is" (lhs:_) = reduce lhs
reduceSyn "does" (lhs:_) = reduce lhs

reduceSyn "package" [kind, exp] = reduceSyn "namespace" [kind, exp, emptyExp]

reduceSyn "namespace" [_kind, exp, body] = do
    val <- evalExp exp
    str <- fromVal val
    when (str `elem` words "MY OUR OUTER CALLER") $ do
        fail $ "Cannot use " ++ str ++ " as a namespace"
    enterPackage (cast str) $ evalExp body

reduceSyn "inline" [langExp, _] = do
    langVal <- evalExp langExp
    lang    <- fromVal langVal
    when (lang /= "Haskell") $
        retError "Inline: Unknown language" langVal
    pkg     <- asks envPackage -- full module name here
    let file = (`concatMap` cast pkg) $ \v -> case v of
                    '-' -> "__"
                    _ | isAlphaNum v -> [v]
                    _ -> "_"
    externRequire "Haskell" (file ++ ".o")
    retEmpty

reduceSyn "=>" [keyExp, valExp] = do
    key <- enterEvalContext cxtItemAny keyExp
    val <- enterEvalContext cxtItemAny valExp
    retItem $ castV (key, val)

reduceSyn syn [lhsExp, rhsExp]
    | last syn == '=' = do
        let op = "&infix:" ++ init syn
        lhs <- enterLValue $ evalExp lhsExp
        val <- readRef =<< fromVal lhs
        evalExp $ Syn "=" [Val lhs, App (_Var op) Nothing [Val val, rhsExp]]

reduceSyn "q:code" [ body ] = expToEvalVal body

reduceSyn "CCallDyn" (Val (VStr quant):methExp:invExp:args) = do
    -- Experimental support for .*$meth, assuming single inheritance.
    str     <- fromVal =<< enterEvalContext (cxtItem "Str") methExp
    let meth = cast ('&':str)
    invVal  <- enterLValue . enterEvalContext cxtItemAny $ invExp
    found   <- findSub meth (Just (Val invVal)) args
    case found of
        Left{}      -> do
            let klugedInv = case unwrap invExp of
                    App{}  -> Val invVal    -- no re-evaluation
                    Syn{}  -> Val invVal    -- no re-evaluation
                    _      -> invExp        -- re-evaluation assumed to be ok
            foundSub    <- findSub meth Nothing (klugedInv:args)
            case foundSub of
                Left{}      -> case quant of
                    "+" -> do
                        typ     <- fromVal invVal
                        retError ("No such method in class " ++ showType typ) meth
                    _   -> do
                        retEmpty
                Right sub   -> applySub sub Nothing (klugedInv:args)
        Right sub | SubMethod <- subType sub, quant /= "?" -> do
            typ     <- fromVal invVal
            subs    <- findAccum meth{ v_package = nextPkg } typ -- Given type, get all methods
            rvs     <- forM (nub (sub:subs)) $ \sub -> applySub sub (Just (Val invVal)) args
            return (VList rvs)
        Right sub   -> do
            -- XXX - Walk multi variants
            applySub sub (Just (Val invVal)) args
    where
    findAccum meth typ = do
        found <- findSub meth (Just (Val (VType typ))) args
        case found of
            Right sub | Just env <- subEnv sub -> do
                let thisPkg = envPackage env
                rest <- findAccum meth (cast thisPkg)
                return (sub:rest)
            _         -> return []

reduceSyn name exps =
    retError "Unknown syntactic construct" (Syn name exps)

data SpecialApp
    = AppSub        !([Exp] -> Eval Val)
    | AppMeth       !(Exp -> [Exp] -> Eval Val)
    | AppSubMeth    !(Maybe Exp -> [Exp] -> Eval Val)
    deriving (Typeable)

class SpecialAppHelper a where
    (...) :: String -> a -> (Var, SpecialApp)

instance SpecialAppHelper (Maybe Exp -> [Exp] -> Eval Val) where
    n ... f = (cast n, AppSubMeth f)

instance SpecialAppHelper ([Exp] -> Eval Val) where
    n ... f = (cast n, AppSub f)

instance SpecialAppHelper (Exp -> [Exp] -> Eval Val) where
    n ... f = (cast n, AppMeth f)

specialApp :: Map Var SpecialApp
specialApp = Map.fromList
    [ "&VAR"        ... \invs args -> do
        res <- forM (maybeToList invs ++ args) $ \exp -> do
            enterLValue (enterEvalContext cxtItemAny exp)
        case res of
            [x] -> return x
            _   -> return $ VList res
    , "&hash"       ... (enterEvalContext cxtItemAny . Syn "\\{}" . (:[]) . Syn ",")
    , "&list"       ... \args -> do
        enterEvalContext cxtSlurpyAny $ case args of
            []    -> Val (VList [])
            [exp] -> exp
            exps  -> Syn "," exps
    , "&item"       ... \args -> do
        enterRValue . enterEvalContext cxtItemAny $ case args of
            [exp] -> exp
            _     -> Syn "," args
    , "&cat"        ... \args -> do
        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args
        val  <- op0Cat vals
        retVal val
    , "&each"       ... \args -> do
        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args
        val  <- op0Each vals
        retVal val
    , "&roundrobin" ... \args -> do
        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args
        val  <- op0RoundRobin vals
        retVal val
    , "&zip"        ... \args -> do
        vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) args
        val  <- op0Zip vals
        retVal val
    , "&yield"     ... \args -> do
        (op1Yield . retControl . ControlLeave (<= SubRoutine) 0) =<<
            case args of
                []      -> retEmpty
                [arg]   -> evalExp arg
                args    -> evalExp (Syn "," args)
    , "&return"     ... \args -> do
        (op1Return . retControl . ControlLeave (<= SubRoutine) 0) =<<
            case args of
                []      -> retEmpty
                [arg]   -> evalExp arg
                args    -> evalExp (Syn "," args)
    , "&goto"       ... \inv args -> do
        sub     <- fromCodeExp inv
        let callerEnv :: Env -> Env
            callerEnv env = let caller = maybe env id (envCaller env) in
                env{ envCaller  = envCaller caller
                   , envContext = envContext caller
                   , envLValue  = envLValue caller
                   , envFrames  = envFrames caller
                   , envPos     = envPos caller
                   }
        local callerEnv $ do
            val <- apply sub Nothing args
            retShift =<< retVal val
            retEmpty
    , "&call"       ... \inv args -> do
        sub     <- fromCodeExp inv
        let callerEnv :: Env -> Env
            callerEnv env = let caller = maybe env id (envCaller env) in
                env{ envCaller  = envCaller caller
                   , envContext = envContext caller
                   , envLValue  = envLValue caller
                   , envFrames  = envFrames caller
                   , envPos     = envPos caller
                   }
        vcap <- case args of
            []      -> return (CaptSub { c_feeds = [] })
            (x:_)   -> castVal =<< fromVal =<< enterRValue (enterEvalContext (cxtItem "Capture") x)
        local callerEnv $ applyCapture sub vcap
    , "&assuming"   ... \inv args -> do
        sub     <- fromCodeExp inv
        case bindSomeParams sub Nothing args of
            Left errMsg      -> fail errMsg
            Right curriedSub -> retVal $ castV $ curriedSub
    , "&infix:=>"   ... reduceSyn "=>"
    , "&circumfix:\\( )" ... \invs args -> do
        feeds <- argsFeed [] Nothing [args]
        case invs of
            Just i' -> do
                invVal  <- reduce i'
                vv      <- fromVal invVal
                return $ VV $ val $ CaptMeth{ c_invocant = vv, c_feeds = feeds }
            Nothing -> do
                return $ VV $ val $ CaptSub{ c_feeds = feeds }
    , "&prefix:|<<" ... reduceSyn "," -- XXX this is wrong as well - should handle at args level
    ]

reduceApp :: Exp -> Maybe Exp -> [Exp] -> Eval Val
reduceApp (Var var) invs args
    | SCodeMulti <- sig = doCall var{ v_sigil = SCode } invs args
    | SCode <- sig = case Map.lookup var specialApp of
        Just (AppSub f)     | Nothing <- invs   -> f args
        Just (AppMeth f)    | Just inv <- invs  -> f inv args
        Just (AppSubMeth f)                     -> f invs args
        _ | Nothing <- invs
          , [inv] <- args
          , not (isInterpolated inv)            -> case inv of
            Syn "named" _   -> normalDispatch
            _               -> do
                -- Try a local lookup of subs only.  If found, don't bother a method lookup.
                rv <- findVar var
                if isJust rv
                    then normalDispatch
                    else doCall var (Just inv) [] -- XXX - This will go away!
        _ -> doCall var invs args
    | otherwise = normalDispatch
    where
    sig = v_sigil var
    normalDispatch  = doCall var invs args

reduceApp subExp invs args = do
    vsub <- enterEvalContext (cxtItem "Code") subExp
    (`juncApply` [ApplyArg dummyVar vsub False]) $ \[arg] -> do
        sub  <- fromVal $ argValue arg
        apply sub invs args

applyCapture :: VCode -> ValCapt -> Eval Val
applyCapture sub capt = apply sub inv (argsPos ++ argsNam)
    where
    argsPos = map (Val . castV) (f_positionals feed)
    argsNam = [Syn "named" [Val (VStr (cast k)), Val (castV (last vs))] | (k, vs@(_:_)) <- Map.toList $ f_nameds feed ]
    feed = mconcat (c_feeds capt)
    inv  = case capt of 
        CaptMeth { c_invocant = val }   -> Just (Val (castV val))
        _                               -> Nothing

argsFeed :: [ValFeed] -> Maybe ValFeed -> [[Exp]] -> Eval [ValFeed]
argsFeed fAcc aAcc [] = return $ fAcc ++ maybeToList aAcc
argsFeed fAcc aAcc [[]] = return $ fAcc ++ maybeToList aAcc
argsFeed fAcc aAcc (argl:als) = do
    acc <- af aAcc argl
    argsFeed fAcc (Just acc) als
    where
    -- af :: Maybe (Feed Val) -> [Exp] -> Eval (Feed Val)
    af res [] = return $ feed res
    -- I'm not sure how much reduction should go on here? E.g. call reduceNamedArg, but what about the val?
    af res (n:args)
        | Syn "named" _ <- unwrapN = do
            Syn "named" [Val (VStr key), valExp] <- reduceNamedArg n
            argVal  <- fromVal =<< reduce valExp
            af (Just $ resFeed{ f_nameds = addNamed (f_nameds resFeed) key argVal }) args
        | Syn "|" (capExp:_) <- unwrapN = do
            cap <- castVal =<< fromVal =<< enterRValue (enterEvalContext (cxtItem "Capture") capExp)
            af (Just (mconcat (resFeed:c_feeds cap))) args
        | App (Var var) Nothing capExps <- unwrapN
        , var == cast "&prefix:|<<" = do
            caps    <- mapM castVal =<< fromVals =<< (enterRValue $ enterEvalContext (cxtSlurpy "Capture") (Syn "," capExps))
            af (Just (mconcat (resFeed:concatMap c_feeds caps))) args
        | otherwise = do
            argVal  <- fromVal =<< reduce n
            af (Just resFeed{ f_positionals = (f_positionals resFeed) ++ [argVal] }) args
        where
        unwrapN = unwrap n
        resFeed = feed res
    feed res = maybe emptyFeed id res
    addNamed :: (Map ID [a]) -> VStr -> a -> Map ID [a]
    addNamed mp k v =
        let id = cast k in
        Map.insertWith (flip (++)) id [v] mp

dummyVar :: Var
dummyVar = cast "$"

chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val
chainFun p1 f1 p2 f2 (v1:v2:vs) = do
    v1' <- forceThunk v1
    v2' <- forceThunk v2
    val <- juncApply (\args -> applyExp SubPrim args f1) (chainArgs p1 [v1', v2'])
    vb  <- fromVal val
    case vb of
        False -> return val
        True  -> do
            vs' <- case vs of
                (v3:rest)   -> do
                    v3' <- forceThunk v3
                    return (v3':rest)
                _           -> return vs
            juncApply (\args -> applyExp SubPrim args f2) (chainArgs p2 (v2':vs'))
    where
    chainArgs prms vals =
        [ ApplyArg name v False
        | name  <- map paramName (prms ++ repeat (last prms))
        | v     <- vals
        ]
    forceThunk (VRef (MkRef (IThunk tv)))   = thunk_force tv
    forceThunk x                            = return x
chainFun _ _ _ _ _ = fail "Impossible: Chained function with less than 2 arguments?"

interpolateExp :: Exp -> Eval [Exp]
interpolateExp exp
    | Syn "|" [x] <- unwrapped      = do
        val <- enterRValue (enterEvalContext (cxtItem "Capture") x)
        interpolateVal val
--  | Syn "|<<" [x] <- unwrapped    = do
--      fail "moose"
    | otherwise                     = return [exp]
    where
    unwrapped = unwrap exp

interpolateVal :: Val -> Eval [Exp]
interpolateVal (VRef (MkRef (IArray av))) = do
    vs <- array_fetch av
    return (map Val vs)
interpolateVal (VRef (MkRef (IHash hv))) = do
    vs <- hash_fetch hv
    return [ Syn "named" [Val (VStr k), Val v] | (k, v) <- Map.toList vs ]
interpolateVal (VRef (MkRef (IPair pv))) = do
    (k, v) <- pair_fetch pv
    return [ Syn "named" [Val k, Val v] ]
interpolateVal val = return [Val val]

isInterpolated :: Exp -> Bool
isInterpolated (Ann _ exp)      = isInterpolated exp
isInterpolated (Syn "|" _)      = True
isInterpolated (Syn "|<<" _)    = True
isInterpolated _                = False

evalInvocant :: Exp -> Eval Val
evalInvocant exp
    | Syn "," xs <- unwrap exp = do
        enterLValue . enterEvalContext cxtItemAny $
            Syn "," (map (\x -> Syn "val" [x]) xs)
    | otherwise = enterLValue $ enterEvalContext cxtItemAny exp

doCall :: Var -> Maybe Exp -> [Exp] -> Eval Val
doCall var invs origArgs = do
    -- First, reduce the invocant fully in item context.
    invs'   <- fmapM (fmap Val . evalInvocant) invs

    -- Support for |$foo here
    args    <- if any isInterpolated origArgs
        then fmap concat (mapM interpolateExp origArgs)
        else return origArgs

    sub     <- findSub var invs' args

    -- XXX - Consider this case:
    --      sub f (*@_) { @_ }
    --      =$fh.f; # App
    --      @foo.f; # Var
    -- We can't go back and re-evaluate the =$fh call under list context
    -- after it failed its method lookup; however, we really need to go back
    -- and re-evaluate @foo under list context.  So we use a klugy heuristic
    -- before this is resolved (by explicit "method is export" and removal
    -- of the one-arg-fallback-to-method altogether):
    let klugedInvs = case fmap unwrap invs of
            Just App{}  -> invs' -- no re-evaluation
            Just Syn{}  -> invs' -- no re-evaluation
            _           -> invs  -- re-evaluation assumed to be ok
    case sub of
        Right sub    -> do
            applySub sub klugedInvs args
        _ | [Syn "," args'] <- unwrap args -> do
            sub <- findSub var klugedInvs args'
            either err (fail errSpcMessage) sub
        -- If a method called failed, fallback to sub call
        Left NoSuchMethod{} | Just inv <- klugedInvs -> do
            doCall var Nothing (inv:args)
        Left failure -> err failure
    where
    errSpcMessage = "Extra space found after " ++ cast var ++ " (...) -- did you mean " ++ cast var ++ "(...) instead?"
    err NoMatchingMulti    = retError "No compatible subroutine found" var
    err NoSuchSub          = retError "No such sub" var
    err (NoSuchMethod typ) = retError ("No such method in class " ++ showType typ) var

applySub :: VCode -> (Maybe Exp) -> [Exp] -> Eval Val
applySub sub invs args
    -- list-associativity
    | MkCode{ subAssoc = A_list }           <- sub
    , (App (Var var') Nothing args'):rest   <- args
    , C_infix <- v_categ var'
    , cast (subName sub) == v_name var'
    = applySub sub invs (args' ++ rest)
    -- fix subParams to agree with number of actual arguments
    | MkCode{ subAssoc = A_list, subParams = (p:_) }   <- sub
    = apply sub{ subParams = length args `replicate` p } invs args
    -- chain-associativity
    | MkCode{ subAssoc = A_chain }      <- sub
    , Nothing                           <- invs
    = case args of
        (App _ Nothing _:_) -> mungeChainSub sub args
        _                   -> applyChainSub sub args
    -- normal application
    | otherwise
    = apply sub invs args
    where
    mungeChainSub :: VCode -> [Exp] -> Eval Val
    mungeChainSub sub args = do
        let MkCode{ subAssoc = A_chain, subParams = [_,_] } = sub
            (App (Var name') invs' args'):rest = args
        theSub   <- findSub name' invs' args'
        case theSub of
            Right sub' | A_chain <- subAssoc sub'
                -> augmentChainSub sub sub' args' rest
            _ -> applyChainSub sub args
    augmentChainSub :: VCode -> VCode -> [Exp] -> [Exp] -> Eval Val
    augmentChainSub sub sub' args' rest = do
        let MkCode{ subBody = fun, subParams = prm } = sub
            MkCode{ subBody = fun', subParams = prm' } = sub'
            augmentedSub = sub
                { subParams = prm' ++ [(last prm){ isLazy = True }]
                , subBody   = Prim $ chainFun prm' fun' prm fun
                }
        applySub augmentedSub Nothing (args' ++ rest)
    applyChainSub :: VCode -> [Exp] -> Eval Val
    applyChainSub sub args = tryAnyComprehension [] args
        where
        vanillaApply = apply sub' Nothing args
        tryAnyComprehension _ [] = vanillaApply
        tryAnyComprehension pre (pivot:post)
            | App (Var var') _ _    <- unwrap pivot
            , var' == cast "&list" = do
                -- List comprehension!  This:
                --      1 < list(@x) < 2
                -- Becomes this:
                --      list(@x).grep:{ 1 < $_ < 2 }
                -- Except we don't introduce a $_ variable, as to avoid shadowing.
                items <- fromVal =<< reduce pivot
                fmap VList . (`filterM` items) $ \item -> do
                    vbool <- enterRValue . enterContext (cxtItem "Bool") $ do
                        apply sub' Nothing (reverse pre ++ (Val item:post))
                    fromVal vbool
            | otherwise = do
                -- Accumulate pre and scan to the next.  Note pre must be reversed as above.
                tryAnyComprehension (pivot:pre) post
        prms    = subParams sub
        -- Align the argument number against the parameter number
        sub'    = sub{ subParams = take (length args) (prms ++ repeat (last prms)) }

applyExp :: SubType -> [ApplyArg] -> Exp -> Eval Val
applyExp _ bound (Prim f) =
    f [ argValue arg | arg <- bound, (argName arg) /= cast "%_" ]
applyExp styp [] body = do
    applyThunk styp [] $ MkThunk (evalExp body) anyType
applyExp styp bound@(invArg:_) body = do
    let (attribute, normal) = partition isAttribute bound
        invocant            = argValue invArg
    -- For each $!foo or $.bar in arg list, assign back to the object directly.
    forM attribute $ \arg -> do
        let name  = dropWhile (not . isAlpha) (cast $ argName arg)
            value = argValue arg
        evalExp $ Syn "=" [Syn "{}" [Val invocant, Val (VStr name)], Val value]
    applyThunk styp normal $ MkThunk (evalExp body) anyType
    where
    isAttribute arg = case v_twigil (argName arg) of
        TAttribute  -> True
        TPrivate    -> True
        _           -> False

applyThunk :: SubType -> [ApplyArg] -> VThunk -> Eval Val
applyThunk _ [] thunk = thunk_force thunk
applyThunk styp bound@(arg:_) thunk = do
    -- introduce self and $_ as the first invocant.
    inv     <- case styp of
        SubPointy               -> aliased [cast "$_"]
        _ | styp <= SubMethod   -> aliased [cast "&self"] -- , "$_"]
        _                       -> return []
    pad <- formal
    enterLex (inv ++ pad) $ thunk_force thunk
    where
    -- Don't generate pad entries for siglets such as "$" and "@".
    formal = sequence
        [ genSym var =<< fromVal val
        | ApplyArg var val _ <- bound
        , v_name var /= nullID
        ]
    aliased names = do
        argRef  <- fromVal (argValue arg)
        mapM (`genSym` argRef) names

{-|
Apply a sub (or other code object) to an (optional) invocant, and
a list of arguments.

Mostly delegates to 'doApply' after explicitly retrieving the local 'Env'.
-}
apply :: VCode       -- ^ The sub to apply
      -> (Maybe Exp) -- ^ Explicit invocant
      -> [Exp]       -- ^ List of arguments (not including explicit invocant)
      -> Eval Val
apply sub invs args = do
    env <- ask
    doApply env sub invs args

-- XXX not entirely sure how this evaluation should proceed
reduceNamedArg :: Exp -> Eval Exp
reduceNamedArg (Syn "named" [keyExp, val]) = do
    key    <- fmap VStr $ fromVal =<< enterEvalContext cxtItemAny keyExp
    return $ Syn "named" [Val key, val]
reduceNamedArg other = return other

        

-- XXX - faking application of lexical contexts
-- XXX - what about defaulting that depends on a junction?
{-|
Apply a sub (or other code object) to an (optional) invocants, and a list of
arguments, in the specified environment.
-}
doApply :: Env         -- ^ Environment to evaluate in
        -> VCode       -- ^ The sub to apply
        -> (Maybe Exp) -- ^ Explicit invocant
        -> [Exp]       -- ^ List of arguments (not including explicit invocant)
        -> Eval Val
doApply env sub@MkCode{ subCont = cont, subBody = fun, subType = typ } invs args = do
    realInvs <- fmapM reduceNamedArg invs
    realArgs <-  mapM reduceNamedArg args  
    case bindParams sub realInvs realArgs of
        Left errMsg -> fail errMsg
        Right sub   -> do
            forM_ (subSlurpLimit sub) $ \limit@(n, _) -> do
                extra <- checkSlurpyLimit limit
                unless (null extra) $ do
                    fail $
                        "Too many slurpy arguments for " ++ cast (subName sub) ++ ": "
                        ++ show ((genericLength (take 1000 extra)) + n) ++ " actual, "
                        ++ show n ++ " expected"
            (syms, bound) <- doBind [] (subBindings sub)
            -- trace (show bound) $ return ()
            val <- local fixEnv $ enterLex syms $ do
                (`juncApply` bound) $ \realBound -> do
                    enterSub sub $ case cont of
                        Just tvar   -> do
                            thunk <- liftSTM $ readTVar tvar
                            applyThunk (subType sub) realBound thunk
                        Nothing     -> applyExp (subType sub) realBound fun
            case typ of 
                SubMacro    -> applyMacroResult val 
                _           -> retVal val
    where
    applyMacroResult :: Val -> Eval Val
    applyMacroResult (VObject o)
        | objType o == mkType "Code::Exp" = reduce (fromObject o)
    applyMacroResult code@VStr{}    = reduceApp (_Var "&eval") (Just $ Val code) []
    applyMacroResult code@VCode{}   = reduceApp (Val code) Nothing []
    applyMacroResult VUndef         = retEmpty
    applyMacroResult _              = fail "Macro did not return an AST, a Str or a Code!"
    fixSub MkCode{ subType = SubPrim } env = env
    fixSub sub env = env
        { envLexical = subPad sub
        , envPackage = maybe (envPackage env) envPackage (subEnv sub)
        , envOuter   = maybe Nothing envOuter (subEnv sub)
        }
    fixEnv :: Env -> Env
    fixEnv | typ >= SubBlock = id
           | otherwise       = envEnterCaller
    doBind :: [PadMutator] -> [(Param, Exp)] -> Eval ([PadMutator], [ApplyArg])
    doBind syms [] = return (syms, [])
    doBind syms ((prm, exp):rest) = do
        -- trace ("<== " ++ (show (prm, exp))) $ return ()
        let var = paramName prm
            cxt = cxtOfSigilVar var
        (val, coll) <- enterContext cxt $ case exp of
            Syn "param-default" [exp, Val (VCode sub)] -> do
                local (fixSub sub . fixEnv) $ enterLex syms $ expToVal prm exp
            _  -> expToVal prm exp
        -- trace ("==> " ++ (show val)) $ return ()
        boundRef <- fromVal val
        newSym   <- genSym var boundRef
        (syms', restArgs) <- doBind (newSym:syms) rest
        return (syms', ApplyArg var val coll:restArgs)
    expToVal :: Param -> Exp -> Eval (Val, Bool)
    expToVal MkOldParam{ isLazy = thunk, isLValue = lv, paramContext = cxt, paramName = var, isWritable = rw } exp = do
        env <- ask -- freeze environment at this point for thunks
        let eval = local (const env{ envLValue = lv }) $ do
                enterEvalContext cxt exp
            thunkify = do
                memo    <- liftSTM $ newTVar Nothing
                let forceThunk = do
                        res <- eval
                        liftSTM $ writeTVar memo (Just res)
                        return res
                    evalThunk = do
                        cur <- liftSTM $ readTVar memo
                        maybe forceThunk return cur
                return . VRef . thunkRef $ MkThunk evalThunk anyType
        val <- if thunk then thunkify else do
            v   <- eval
            typ <- evalValType v
            let cls = envClasses env
            if isaType cls "Junction" typ then return v else do
            case (lv, rw) of
                (True, True)    -> return v
                (True, False)   -> do
                    --- not scalarRef! -- use the new "transparent IType" thing!
                    case showType (typeOfSigilVar var) of
                        "Hash"  -> ($ v) . fix $ \redo x -> case x of
                            VRef (MkRef (IHash h)) -> return (VRef $ hashRef h) 
                            VRef ref@(MkRef IScalar{}) -> redo =<< readRef ref
                            _ -> fmap (VRef . hashRef) (fromVal v :: Eval VHash)
                        "Array" -> ($ v) . fix $ \redo x -> case x of
                            VRef (MkRef (IArray a)) -> return (VRef $ arrayRef a) 
                            VRef ref@(MkRef IScalar{}) -> redo =<< readRef ref
                            _ -> fmap (VRef . arrayRef) (fromVal v :: Eval VArray)
                        _       -> case v of
                            VRef (MkRef IScalar{}) -> return (VRef $ scalarRef v) 
                            VRef _ -> return v -- XXX - preserving ref
                            _ -> return (VRef $ scalarRef v) 
                (False, False)  -> return v -- XXX reduce to val?
                (False, True)   -> do
                    -- make a copy
                    ref <- newObject (typeOfSigilVar var)
                    writeRef ref v
                    return (VRef ref)
        return (val, (isSlurpyCxt cxt || isCollapsed (typeOfCxt cxt)))
    checkSlurpyLimit :: (VInt, Exp) -> Eval [Val]
    checkSlurpyLimit (n, exp) = do
        listVal <- enterLValue $ enterEvalContext (cxtItem "Array") exp
        list    <- fromVal listVal
        elms    <- mapM fromVal list -- flatten
        return $ genericDrop n (concat elms :: [Val])
    isCollapsed :: Type -> Bool
    isCollapsed typ
        | isaType (envClasses env) "Bool" typ        = True
        | isaType (envClasses env) "Junction" typ    = True
        | otherwise                     = False

doFetch :: (Val -> Eval (IVar VScalar))
        -> (Val -> Eval Val)
        -> (forall v. (Value v) => Eval v)
        -> Bool
        -> Bool
        -> Eval Val
doFetch fetchElem fetchVal fetchIdx isLV isSV = case (isLV, isSV) of
    (True, True) -> do
        -- LValue, Scalar context
        idx <- fetchIdx
        elm <- fetchElem idx
        retIVar elm
    (True, False) -> do
        -- LValue, List context
        idxList <- fetchIdx
        elms    <- mapM fetchElem idxList
        retIVar $ IArray elms
    (False, True) -> do
        -- RValue, Scalar context
        idx <- fetchIdx
        fetchVal idx
    (False, False) -> do
        -- RValue, List context
        idxList <- fetchIdx
        fmap VList $ mapM fetchVal idxList

mkFetch :: (Value n) => Eval (n -> Eval t) -> Val -> Eval t
mkFetch f v = do
    f' <- f
    v' <- fromVal v
    f' v'

afterLeave :: VCode -> (VCode -> [VCode]) -> VCode
afterLeave code@MkCode{ subBody = Syn "block" [Val (VCode code')] } f =
    code{ subBody = Syn "block" [Val (VCode (afterLeave code' f))] }
afterLeave code f = code{ subLeaveBlocks = subLeaveBlocks code ++ f code }

beforeLeave :: VCode -> (VCode -> [VCode]) -> VCode
beforeLeave code@MkCode{ subBody = Syn "block" [Val (VCode code')] } f =
    code{ subBody = Syn "block" [Val (VCode (afterLeave code' f))] }
beforeLeave code f = code{ subLeaveBlocks = f code ++ subLeaveBlocks code }

beforeEnter :: VCode -> (VCode -> [VCode]) -> VCode
beforeEnter code@MkCode{ subBody = Syn "block" [Val (VCode code')] } f =
    code{ subBody = Syn "block" [Val (VCode (beforeEnter code' f))] }
beforeEnter code f = code{ subEnterBlocks = f code ++ subEnterBlocks code }

fromCodeExp :: Exp -> Eval VCode
fromCodeExp x = case x of
    Syn "block" [Val VCode{}]   -> fromClosure x
    Syn "block" [_]             -> do
        env <- ask
        return $ mkCode
            { subEnv        = Just env
            , subType       = SubBlock
            , subParams     = [defaultScalarParam]
            , subBody       = x
            }
    _                           -> fromClosure x
    where
    fromClosure = (fromVal =<<) . enterRValue . enterEvalContext (cxtItem "Code")

