hmumps-0.1.1: HMumps/Runtime.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleContexts, OverloadedStrings, ViewPatterns, ScopedTypeVariables,
             Rank2Types, GeneralizedNewtypeDeriving
  #-}

module HMumps.Runtime(RunState(..),
                      Env(..),
                      emptyState,
                      eval,
                      exec,
                      Normalizable(..),
                      setX, setY,
                      addX, addY,
                      RunMonad,
                      step
                     )
where

import Prelude hiding (lookup,break,map)

import Data.Char (chr)
import Data.String
import Data.Map
import Data.MValue hiding (join)
import qualified Data.MValue as M
import Data.MArray
import Data.Monoid

import HMumps.Routine
import HMumps.SyntaxTree
import HMumps.Parsers

import Control.Applicative hiding (empty)
import Control.Monad.State
import Control.Monad.Error

import System.Exit(exitWith, ExitCode(..))

newtype RunMonad a = RM {runRunMonad :: ErrorT String (StateT [RunState] IO) a}
    deriving (Functor, Monad, MonadIO, MonadState [RunState], MonadError String)

step :: (MonadState [RunState] m, MonadIO m) => RunMonad a -> m (Either String a)
step k
    = do
  s <- get
  (a, s') <- liftIO $ flip runStateT s $ runErrorT $ runRunMonad k
  put s'
  return a

-- |Anything you may ever want to strip indirection off of should
--  be an instance of this class
class Normalizable a where
    normalize :: a -> RunMonad a

instance Normalizable Vn where
    normalize (IndirectVn expr subs)
     = do result <- eval expr
          let str = asString result
          case parse parseVn "Indirect VN" str of
            Right (IndirectVn expr' subs') -> normalize $ IndirectVn expr' (subs' ++ subs)
            Right (Lvn label subs') -> return $ Lvn label (subs' ++ subs)
            Right (Gvn label subs') -> return $ Gvn label (subs' ++ subs)
            Left err -> normalizeError err
    normalize x = return x

instance Normalizable WriteArg where
    normalize (WriteIndirect expr)
     = do result <- eval expr
          let str = asString result
          case parse parseWriteArg "Indirect Write Argument" str of
            Right wa -> case wa of
                          w@(WriteIndirect _) -> normalize w
                          w -> return w
            Left err -> normalizeError err
    normalize x = return x

instance Normalizable KillArg where
    normalize (KillIndirect expr)
        = do
      result <- eval expr
      let str = asString result
      case parse (mlist1 parseKillArg) "Indirect KILL argument" str of
        Right args -> do
          args' <- mapM normalize args
          case args' of
            [arg] -> return arg
            _     -> return $ KillArgList args'
        Left err -> normalizeError err
    normalize x = return x

instance Normalizable NewArg where
    normalize (NewIndirect expr)
        = do
      result <- eval expr
      let str = asString result
      case parse (mlist1 parseNewArg) "Indirect NEW argument" str of
        Right args -> do
          args' <- mapM normalize args
          case args' of
            [arg] -> return arg
            _ -> return $ NewArgList args'
        Left err -> normalizeError err
    normalize x = return x

instance Normalizable DoArg where
    normalize (DoArgIndirect expr)
        = do
      result <- eval expr
      let str = asString result
      case parse (mlist1 parseDoArg) "Indirect DO argument" str of
        Right args -> do
          args' <- mapM normalize args
          case args' of
            [arg] -> return arg
            _ -> return $ DoArgList args'
        Left err -> normalizeError err
    normalize x = return x

instance Normalizable Routineref where
    normalize (RoutinerefIndirect expr)
        = do
      result <- eval expr
      let str = asString result
      case parse parseRoutineRef "Indirect routine ref" str of
        Right ref -> normalize ref
        Left err -> normalizeError err
    normalize x = return x

instance Normalizable Label where
    normalize (LabelIndirect expr)
        = do
      str <- asString <$> eval expr
      case parse parseLabel "Indirect label" str of
        Right lbl -> normalize lbl
        Left err -> normalizeError err
    normalize x = return x

instance Normalizable GotoArg where
    normalize (GotoArgIndirect expr)
        = do
      str <- asString <$> eval expr
      case parse parseGotoArg "GOTO argument" str of
        Right arg -> return arg
        Left err -> normalizeError err
    normalize x = return x

normalizeError :: (Show a, MonadIO m) => a -> m b
normalizeError err = (liftIO . putStrLn . show $ err) >> fail ""

-- | Remove any KillArgList constructors
flattenKillArgs :: [KillArg] -> [KillArg]
flattenKillArgs (KillArgList args':args) = flattenKillArgs args' ++ flattenKillArgs args
flattenKillArgs [] = []
flattenKillArgs (x:xs) = x : flattenKillArgs xs

-- | Remove any NewArgList constructors
flattenNewArgs :: [NewArg] -> [NewArg]
flattenNewArgs (NewArgList args':args) = flattenNewArgs args' ++ flattenNewArgs args
flattenNewArgs [] = []
flattenNewArgs (x:xs) = x : flattenNewArgs xs

data RunState = RunState { env       :: Maybe Env
                         , tags      :: Routine
                         , gotoTags  :: Routine
                         }

emptyState :: [RunState]
emptyState = [emptyFrame]

emptyFrame :: RunState
emptyFrame = RunState Nothing (\_ -> Nothing) (\_ -> Nothing)

data Env = Env EnvTag (Map String EnvEntry)

data EnvTag = NormalEnv
            | StopEnv
 deriving Eq

data EnvEntry = LookBack (Maybe Name)
              | Entry MArray


killLocal :: Name -> RunMonad ()
killLocal = modify . go

 where go _ [] = []
       go label (f:fs)
           | noEnvFrame f = f : go label fs
           | otherwise
               = case f of
                   RunState (Just (Env envTag envMap)) rou gRou
                       -> case label `lookup` envMap of
                            Nothing
                                | envTag == StopEnv -> f:fs
                                | otherwise -> f : go label fs
                            Just (Entry _ary)
                                -> (RunState (Just (Env envTag (label `delete` envMap))) rou gRou) : fs
                            Just (LookBack Nothing) -> f : go label fs
                            Just (LookBack (Just newLabel)) -> f : go newLabel fs
                   _ -> error "Fatal error in KILL"

       noEnvFrame (RunState Nothing _ _) = True
       noEnvFrame _ = False

new :: Name -> RunMonad ()
new label
    = modify $ \state ->
      case state of
        [] -> fail "NEW called with an empty stack!"
        (x:xs) -> go x : xs

 where
   go (RunState Nothing r gr) = RunState (Just (Env NormalEnv (insert label (Entry mEmpty) empty))) r gr
   go (RunState (Just ev) r gr)
       = let newEnv
                 = case ev of
                    Env NormalEnv eMap -> Env NormalEnv $ insert label (Entry mEmpty) eMap
                    Env StopEnv eMap -> Env StopEnv $ delete label eMap
         in RunState (Just newEnv) r gr

newExclusive :: [Name] -> RunMonad ()
newExclusive labels
    = modify $ \state ->
      case state of
        [] -> fail "NEW called with an empty stack!"
        (x:xs) -> go x : xs

 where
   go (RunState oldEnv r gr)
       = let newEnv = foldr addLabel (Env StopEnv mempty) labels
         in RunState (Just newEnv) r gr
    where
      addLabel label@(inEnv oldEnv -> Just entry) (Env _StopEnv eMap)
          = Env StopEnv $ insert label entry eMap
      addLabel label (Env _StopEnv eMap)
          = Env StopEnv $ insert label (LookBack Nothing) eMap

      inEnv Nothing _ = Nothing
      inEnv (Just (Env _ eMap)) lbl
          = lbl `lookup` eMap


fetch' :: String -> [RunState] -> Maybe MArray
fetch' str xs = join . fst $ foldl helper (Nothing,str) [x | Just x <- fmap env xs] where

 helper :: (Maybe (Maybe MArray),Name) -> Env -> (Maybe (Maybe MArray), Name)

 helper rhs@(Just _, _) _ = rhs
 helper (_,name) (Env tag m) = case tag of
                   NormalEnv -> case name `lookup` m of
                                  Nothing -> (Nothing, name)
                                  Just (Entry ma) -> (Just (Just ma), name)
                                  Just (LookBack newname') -> case newname' of
                                                             Just newname -> (Nothing, newname)
                                                             Nothing      -> (Nothing, name)
                   StopEnv   -> case name `lookup` m of
                                  Nothing -> (Just Nothing, name)
                                  Just (Entry ma) -> (Just (Just ma), name)
                                  Just (LookBack newname') -> case newname' of
                                                             Just newname -> (Nothing, newname)
                                                             Nothing      -> (Nothing, name)

-- |Returns the MArray associated with the named local var, or the empty MArray
fetch :: String -> RunMonad MArray
fetch str = do result <- (fetch' str) `liftM` get
               case result of
                  Just x  -> return x
                  Nothing -> return mEmpty


put' :: String -> MArray -> [RunState] -> [RunState]
put' _ _ [] = error "SET called with an empty stack"
put' str ma (x:[]) = case (env x) of
                      Nothing          -> x {env = Just $ Env NormalEnv (insert str (Entry ma) empty)} : []
                      Just (Env tag m) -> x {env = Just $ Env tag       (insert str (Entry ma) m)} : []
put' str ma (x:xs) = case (env x) of
                      Nothing          -> x : (put' str ma xs)
                      Just (Env tag m) -> let enter = x {env = Just $ Env tag (insert str (Entry ma) m)} : xs in
                                          case str `lookup` m of
                                            Nothing -> case tag of
                                                         NormalEnv -> x : (put' str ma xs)
                                                         StopEnv   -> enter

                                            Just (Entry _)              ->  enter
                                            Just (LookBack Nothing)     -> x : (put' str  ma xs)
                                            Just (LookBack (Just str')) -> x : (put' str' ma xs)

setVar :: String -> MArray -> RunMonad ()
setVar str ma = modify (put' str ma)

change :: String -> [MValue] -> MValue -> RunMonad ()
change name subs val = do ma <- fetch name
                          setVar name (arrayUpdate ma subs val)

kill :: Name -> [MValue] -> RunMonad ()
kill label [] = killLocal label
kill label subs = do
  ma <- fetch label
  setVar label (killSub ma subs)

orM :: Monad m => [m Bool] -> m Bool
orM [] = return False
orM (x:xs) = do x' <- x
                if x'
                 then return True
                 else orM xs

-- |A return value of 'Nothing' indicates we did not quit, and should not unroll the stack.
-- A return value of 'Just Nothing' means we should quit with no return value.
-- A return value of 'Just (Just mv)' means that we should quit with a return value of mv.
exec :: Line -> RunMonad (Maybe (Maybe MValue))
exec []  = return Nothing

-- special commamds which (may) use the rest of the command list, or may
-- return without processing the entire list
exec (ForInf:cmds) = forInf (cycle cmds)
exec ((For vn farg):cmds) = case farg of
                              ForArg1 expr -> exec $ (Set Nothing [([vn],expr)]) : ForInf : cmds
                              ForArg2 exprStart exprInc ->
                               do mStart <- eval exprStart
                                  mInc   <- eval exprInc
                                  exec $ (Set Nothing [([vn],ExpLit mStart)]) : ForInf : cmds ++
                                    [Set Nothing [([vn],ExpBinop Add (ExpVn vn) (ExpLit mInc))]]
                              ForArg3 exprStart exprInc exprTest -> 
                               do mStart <- eval exprStart
                                  mInc   <- eval exprInc
                                  mTest  <- eval exprTest
                                  exec $ (Set Nothing [([vn],ExpLit mStart)]) : ForInf : cmds ++

                                   [Quit (Just $ if mToBool (mTest `mLT` 0)
                                      then ExpBinop LessThan    (ExpVn vn) (ExpLit (mTest + 1))
                                      else ExpBinop GreaterThan (ExpVn vn) (ExpLit (mTest - 1))) Nothing,

                                    Set Nothing [([vn],ExpBinop Add (ExpVn vn) (ExpLit mInc))]]

exec ((Break cond):cmds) = do
  condition <- evalCond cond
  when condition $ break
  exec cmds

exec (Else:cmds) = do t <- getTest
                      if not t
                       then exec cmds
                       else return Nothing
exec ((If xs):cmds) = do let xs' =  fmap eval xs
                         cond <- orM $ (liftM . liftM) mToBool xs'
                         if cond
                          then setTest True  >> exec cmds
                          else setTest False >> return Nothing
exec ((Halt cond):cmds)
    = do
  condition <- evalCond cond
  if condition
     then liftIO (exitWith ExitSuccess) >> return Nothing
     else exec cmds

exec ((Quit cond arg):cmds)
    = do
  condition <- evalCond cond
  if condition
     then case arg of
            Nothing -> return $ Just Nothing
            Just expr -> do
                     mv <- eval expr
                     return $ Just $ Just mv
     else exec cmds

exec ((Goto cond args):cmds)
    = do
  condition <- evalCond cond
  if condition
   then execGotoArgs args
   else exec cmds

 where
   execGotoArgs [] = exec cmds
   execGotoArgs (arg:rest)
       = do
     GotoArg argCond entryRef <- normalize arg
     condition <- evalCond argCond
     if condition
      then do
         (rou,tag) <- unpackEntryRef entryRef
         liftM Just $ goto rou tag
      else execGotoArgs rest

   unpackEntryRef :: EntryRef -> RunMonad (Maybe Name, Name)
   unpackEntryRef entryRef =
       case entryRef of
         Routine rRef -> do
                       Routineref name <- normalize rRef
                       return (Just name, "")
         Subroutine label' Nothing Nothing -> do
                       label <- labelName label'
                       return (Nothing, label)
         Subroutine label' Nothing (Just rRef) -> do
                       label <- labelName label'
                       Routineref name <- normalize rRef
                       return (Just name, label)
         Subroutine _ Just{} _ -> fail "unable to process numberic offsets for DO or GOTO"

   labelName :: Label -> RunMonad Name
   labelName label' = do
     label <- normalize label'
     case label of
       Label name -> return name
       LabelInt{} -> fail "Unable to handle numeric labels"
       _ -> error "Fatal error handling entry reference"
     

-- regular commands go through the command driver

exec (cmd:cmds)
    = do
  go cmd
  exec cmds

 where
   go Nop = return ()

   go (Write cond ws) = do
     condition <- evalCond cond
     when condition $ write ws

   go (Set cond sas) = do
     condition <- evalCond cond
     when condition $ set sas

   go (Xecute cond arg) = do
     condition <- evalCond cond
     when condition $ do
       str <- asString `liftM` eval arg
       case parse parseCommands "XECUTE" str of
         Left _err -> fail "" -- todo, better error message
         Right xcmds -> do
          modify (emptyFrame:)
          res <- exec $ xcmds ++ [Quit Nothing Nothing]
          case res of
            Just (Just{}) -> fail "XECUTE cannot return with a value"
            _ -> return ()
          modify tail

   -- the "routine" argument is only for use with GOTO,
   -- so we ignore it for now
   go (Block cond rou doLines) = do
     condition <- evalCond cond
     when condition $ do
       RunState _ r _ <- gets head
       modify (emptyFrame {tags = r,gotoTags=rou}:)
       doBlockLines doLines
       modify tail
    where
      doBlockLines [] = return ()
      doBlockLines (doCmds:rest)
          = do
        res <- exec doCmds
        case res of
          Nothing -> doBlockLines rest
          Just Nothing -> return ()
          Just Just{} -> fail "Argumentless DO block cannot quit with a value"


   go (Kill cond args) = do
     condition <- evalCond cond
     when condition $ case args of
         [] -> fail "Sorry, I don't know how to kill everything"
         _ -> do
           args' <- flattenKillArgs `liftM` (mapM normalize args)
           forM_ args' $ \arg ->
               case arg of
                 KillSelective vn'
                     -> do
                         vn <- normalize vn'
                         case vn of
                           Lvn name subs' -> do
                                    subs <- mapM eval subs'
                                    kill name subs
                           _ -> fail "I can only kill locals, sorry"
                 _ -> fail "I can only do selective kills, sorry!"

   go (New cond args) = do
     condition <- evalCond cond
     when condition $ case args of
         [] -> newExclusive []
         _ -> do
           args' <- flattenNewArgs `liftM` (mapM normalize args)
           forM_ args' $ \arg ->
               case arg of
                 NewSelective name -> new name
                 NewExclusive names -> newExclusive names
                 _ -> error "Fatal error processing arguments to NEW"

   go (Do cond args) = do
      condition <- evalCond cond
      when condition $ forM_ args $ \arg' -> do
          arg <- normalize arg'
          case arg of
            DoArgList argList -> mapM_ processDo argList
            _ -> processDo arg

   go c =  fail $ "Sorry, I don't know how to execute: " ++ (takeWhile (\x -> not (x==' ')) $ show c)

processDo :: DoArg -> RunMonad ()
processDo (DoArg cond entryRef args)
    = do
  condition <- evalCond cond
  when condition $ do
    case entryRef of
      Routine routineRef'
          -> do
        Routineref rou <- normalize routineRef'
        sub (Just rou) "" args
      Subroutine label' Nothing Nothing
          -> do
        label <- normalize label'
        case label of
          Label name -> sub Nothing name args
          LabelInt{} -> fail "Cannot use numeric labels"
          _ -> error "fatal error in DO"
      Subroutine label' Nothing (Just rouRef')
          -> do
        Routineref rou <- normalize rouRef'
        label <- normalize label'
        case label of
          Label name -> sub (Just rou) name args
          LabelInt{} -> fail "Cannot use numeric labels"
          _ -> error "fatal error in DO"
      Subroutine _ Just{} _ -> fail "Unable to execute DO with a numeric offset"
processDo _ = error "fatal error in DO"

evalCond :: Maybe Expression -> RunMonad Bool
evalCond Nothing = return True
evalCond (Just e) = mToBool `liftM` eval e

set :: [SetArg] -> RunMonad ()
set [] = return ()
set ((vns,expr):ss) = do vns' <- mapM normalize vns
                         mv <- eval expr
                         mapM_ (setHelper mv) vns' >> set ss
 where setHelper mv (Lvn name subs) = do subs' <- mapM eval subs
                                         change name subs' mv
       setHelper _ (Gvn _ _)        = fail "We don't supposrt global variables yet.  sorry."
       setHelper _ (IndirectVn _ _) = fail "Variable name should be normalized"

write :: [WriteArg] -> RunMonad ()
write = mapM_ f
 where f wa = do
         wa' <- normalize wa
         case wa' of
           WriteExpression expr -> do m <- eval expr
                                      let s = asString m
                                      liftIO $ putStr s
                                      addX $ fromIntegral $ length s
           WriteFormat fs -> writeFormat fs
           WriteIndirect _ -> fail "write argument should be normalized"

writeFormat :: [WriteFormatCode] -> RunMonad ()
writeFormat = mapM_ f
 where
  f Formfeed = liftIO (putChar '\f') >> setY 1
  f Newline  = liftIO (putChar '\n') >> setX 1 >> addY 1
  f (Tab n)  = do x <- getX
                  let n' = fromIntegral n
                  if x >= n'
                   then return ()
                   else do liftIO (putStr $ (replicate . floor) (n'-x) ' ')
                           setX n'

setX :: MValue -> RunMonad ()
setX = change "$x" []

setY :: MValue -> RunMonad ()
setY = change "$y" []

getX :: RunMonad MValue
getX = getLocal "$x" []

getY :: RunMonad MValue
getY = getLocal "y" []

addX :: Int -> RunMonad ()
addX n = do x <- getX
            setX (x + fromIntegral n)

addY :: Int -> RunMonad ()
addY n = do y <- getY
            setY (y + fromIntegral n)

getLocal :: String -> [MValue] -> RunMonad MValue
getLocal label subs = do ma <- fetch label
                         return $ case mIndex ma subs of
                           Just mv -> mv
                           Nothing -> fromString ""                         

getLocalArray :: String -> [MValue] -> RunMonad (Maybe MArray)
getLocalArray label subs = do
  ma <- fetch label
  return $ mSubArray ma subs

forInf ::  Line -> RunMonad (Maybe (Maybe MValue))
forInf ((Quit cond Nothing):xs) = case cond of
    Nothing  -> return Nothing
    Just expr -> do mv <- eval expr
                    if mToBool mv
                     then return Nothing
                     else forInf xs
forInf ((Quit _ _):_) = fail "QUIT with argument in a for loop"
forInf (cmd:xs) = exec [cmd] >> forInf xs
forInf [] = forInf []  -- dumb

break ::  RunMonad ()
break = fail "BREAK not working"

getTest :: RunMonad Bool
getTest = mToBool `liftM` getLocal "$test" []

setTest :: Bool -> RunMonad ()
setTest =  change "$test" [] . boolToM


eval :: Expression -> RunMonad MValue
eval (ExpLit m) = return m
eval (ExpVn vn) = do vn' <- normalize vn
                     case vn' of
                       Lvn label subs -> do mvs <- mapM eval subs
                                            getLocal label mvs
                       Gvn _ _        -> fail "Globals not yet implemented"
                       IndirectVn _ _ -> fail "normalized VNs should not be indirect"

eval (ExpUnop unop expr) = do mv <- eval expr
                              return $ case unop of
                                UNot   -> mNot   mv
                                UPlus  -> mv+0
                                UMinus -> negate mv
eval (ExpBinop binop lexp rexp) 
 = do lv <- eval lexp
      rv <- eval rexp
      return $ case binop of
        Concat      -> lv `mConcat` rv
        Add         -> lv + rv
        Sub         -> lv - rv
        Mult        -> lv * rv
        Div         -> lv / rv
        Rem         -> lv `mRem` rv
        Quot        -> lv `mQuot` rv
        Pow         -> lv `mPow` rv
        And         -> lv `mAnd` rv
        Or          -> lv `mOr` rv
        Equal       -> boolToM $ lv == rv
        LessThan    -> lv `mLT` rv
        GreaterThan -> lv `mGT` rv
        Follows     -> lv `follows` rv
        Contains    -> lv `contains` rv
        SortsAfter  -> boolToM $ lv > rv
-- eval (Pattern _ _)   = fail "Can't evaluate pattern matches"
eval (FunCall label "" args) = function Nothing label args 
eval (FunCall label rou args) = function (Just rou) label args
eval (ExpBifCall bif)   = evalBif bif

function :: Maybe Name -> Name -> [FunArg] -> RunMonad MValue
function routine tag args
    = do
  retVal <- call routine tag args
  case retVal of
    Nothing -> fail "Function quit without returning a value"
    Just v -> return v


sub :: Maybe Name -> Name -> [FunArg] -> RunMonad ()
sub routine tag args
    = do
  retVal <- call routine tag args
  case retVal of
    Nothing -> return ()
    Just{} -> fail "Subroutine quit with a value!"


call :: Maybe Name -> Name -> [FunArg] -> RunMonad (Maybe MValue)
call Nothing tag args = localCall tag args
call (Just routine) "" args = call (Just routine) routine args
call (Just routine) tag args = remoteCall tag routine args


 
localCall :: Name -> [FunArg] -> RunMonad (Maybe MValue)
localCall label args = do (r :: Routine) <- (tags . head) `liftM` get
                          case r label of
                            Nothing -> fail $ "Noline: " ++ label
                            Just (argnames, cmds) -> funcall args argnames cmds r


remoteCall :: Name -> Name -> [FunArg] -> RunMonad (Maybe MValue)
remoteCall label routine args
    = openRemote routine $ \r ->
      case r label of
        Nothing -> fail $ "Noline: " ++ label ++ "^"  ++ routine
        Just (argnames, cmds) -> funcall args argnames cmds r

goto :: Maybe Name -> Name -> RunMonad (Maybe MValue)
goto Nothing tag
    = do
  s <- gets head
  doGoto tag (tags s) (gotoTags s)
goto (Just rouName) tag
    = openRemote rouName $ \r -> doGoto tag r r

doGoto :: Name -> Routine -> Routine -> RunMonad (Maybe MValue)
doGoto tag r gr
    = case gr tag of
        Nothing -> fail $ "Noline: " ++ tag
        Just ([], cmds) -> do
                   modify $ \(s:ss) -> s {tags=r,gotoTags=gr} : ss
                   runLines cmds
        Just{} -> fail "Error in GOTO: tag should not take arguments"

openRemote :: MonadIO m => Name -> (Routine -> m a) -> m a 
openRemote routine k
    = do
  let filename = routine ++ ".hmumps"
  text <- liftIO $ readFile filename
  case parse parseFile filename text of
    Left a -> (fail . show) a
    Right f -> let r = pack $ transform f in
               k r

evalBif :: BifCall -> RunMonad MValue
evalBif (BifChar args') = do
  args <- mapM eval args'
  let str = fmap (chr . asInt) args
  return $ fromString str

evalBif BifX = getX
evalBif BifY = getY
evalBif BifTest = boolToM `liftM` getTest
evalBif (BifOrder vn' expForward) = do
  vn <- normalize vn'
  case vn of
    Lvn label subs' -> do
            subs <- mapM eval subs'
            case unSnoc subs of
              Nothing -> fail "Cannot $ORDER with no subscripts"
              Just (rest,lastSub)
                  -> do
                ma <- getLocalArray label rest
                case ma of
                  Nothing -> return ""
                  Just a -> do
                      forward <- case expForward of
                                   Nothing -> return True
                                   Just ex -> mToBool `liftM` eval ex
                      case order a forward lastSub of
                        Nothing -> return ""
                        Just v -> return v
    Gvn{} -> fail "$ORDER on globals is not supported"
    _ -> error "Fatal error in ORDER"
evalBif (BifReplace haystack' needle' replacement') = do
  haystack <- eval haystack'
  needle <- eval needle'
  replacement <- eval replacement'
  return $ M.join replacement $ M.split needle haystack

-- evalBif bif = fail $ "oops! I don't know what to do with " ++ show bif


-- | returns the front of a list plus the last element.
-- returns Nothing if the list is empty.
unSnoc :: [a] -> Maybe ([a],a)
unSnoc [] = Nothing
unSnoc (x:xs) = Just $ case unSnoc xs of
                         Nothing -> ([],x)
                         Just ~(ys,y) -> (x:ys,y)

funcall :: [FunArg] -> [Name] -> [Line] -> Routine -> RunMonad (Maybe MValue)
funcall args' argnames cmds r = 
    let (pairs, remainder) = zipRem args' argnames in
    case remainder of
      Just (Left _) -> fail "Supplied too many parameters to function"
      _ -> do m <- foldM helper empty pairs
              let newframe = RunState (Just $ Env NormalEnv m) r r
              modify (newframe:)
              x <- runLines cmds
              modify tail
              return x

 where helper :: Map Name EnvEntry -> (FunArg, Name) -> RunMonad (Map Name EnvEntry)
       helper m (arg,name) = case arg of
             FunArgExp expr -> do mval <- eval expr
                                  let entry = Entry $ arrayUpdate mEmpty [] mval
                                  return $ insert name entry m
             FunArgName name' -> return $ insert name (LookBack $ Just name') m

runLines :: [Line] -> RunMonad (Maybe MValue)
runLines [] = return Nothing
runLines (x:xs) = do result <- exec x
                     case result of
                       Nothing -> runLines xs
                       Just x' -> return x'

zipRem :: [a] -> [b] -> ([(a,b)],Maybe (Either [a] [b]))
zipRem [] []         = ([],Nothing)
zipRem [] xs         = ([],Just $ Right xs)
zipRem xs []         = ([],Just $ Left  xs)
zipRem (x:xs) (y:ys) = let (pairs, remainder) = zipRem xs ys
                       in ((x,y):pairs,remainder)