# LANGUAGE FlexibleContexts , ParallelListComp , Rank2Types #

-- | The heart of the BASIC interpreter. It is implemented on top
-- of the BASIC monad.

module Language.VintageBasic.Interpreter(interpLines) where

import Control.Monad.CPST.DurableTraps
import Data.List
import Data.Maybe
import Language.VintageBasic.Builtins(Builtin(..))
import Language.VintageBasic.LexCommon(Tagged(..))
import Language.VintageBasic.BasicMonad
import Language.VintageBasic.Result
import Language.VintageBasic.Printer(printFloat)
import Language.VintageBasic.RuntimeParser(dataValsP,readFloat,trim)
import Language.VintageBasic.Syntax
import Text.ParserCombinators.Parsec(parse)
import Text.ParserCombinators.Parsec.Pos(sourceLine)

-- | Entry in the jump table, a lookup table that holds both
-- program code and @DATA@ statements, indexed by 'Label'.
data JumpTableEntry = JumpTableEntry {
    jtLabel :: Label,     -- ^ the starting line number
    jtProgram :: Program, -- ^ program source starting at that line
    jtData :: [String]    -- ^ @DATA@ strings starting at that line
}

type JumpTable = [JumpTableEntry]

programLookup :: JumpTable -> Label -> (Maybe Program)
programLookup jt lab = lookup lab [(jtLabel jte, jtProgram jte) | jte <- jt]

dataLookup :: JumpTable -> Label -> (Maybe [String])
dataLookup jt lab = lookup lab [(jtLabel jte, jtData jte) | jte <- jt]

-- | Lazily interprets a list of BASIC lines of code.

interpLines :: [Line] -> Program

-- Note that jumpTable and interpLine are mutually recursive.
-- The jumpTable contains interpreted code, which in turn calls
-- the jumpTable to look up code.  Since the jumpTable is a single
-- data structure, it memoizes interpreted code, making 'interpLines'
-- a just-in-time compiler.  (The only time code is reinterpreted
-- is following an @IF@ statement.)

interpLines progLines =
    let interpLine line@(Line lab stmts) =
            (lab, mapM_ (interpTS jumpTable) stmts, dataFromLine line)
        makeTableEntry (accumCode, accumData) (lab, codeSeg, lineData) =
            let accumCode' = codeSeg >> accumCode
                accumData' = lineData ++ accumData
                in ((accumCode', accumData'), JumpTableEntry lab accumCode' accumData')
        jumpTable = snd $ mapAccumR makeTableEntry (done, []) $ map interpLine progLines
    in do
        case jumpTable of
            ((JumpTableEntry _ prog dat) : _) -> do
                seedRandomFromTime
                setDataStrings dat
                prog
            [] -> done

-- Expression evaluation

boolToVal :: Bool -> Val
boolToVal t = if t then FloatVal (-1) else FloatVal 0

isNext :: Result -> Bool
isNext (LabeledRuntimeException _ (Next Nothing)) = True
isNext _ = False

isNextVar :: VarName -> Result -> Bool
isNextVar (VarName FloatType v1) (LabeledRuntimeException _ (Next (Just v2))) = v1==v2
isNextVar _ _ = False

isReturn :: Result -> Bool
isReturn (LabeledRuntimeException _ Return) = True
isReturn _ = False

liftFVOp1 :: (Float -> Float) -> Val -> Code Val
liftFVOp1 f (FloatVal v1) =
    let v = f v1 in seq v $ return $ FloatVal v
liftFVOp1 _ _             = typeMismatch

liftFVBuiltin1 :: (Float -> Float) -> [Val] -> Code Val
liftFVBuiltin1 f [FloatVal v1] =
    let v = f v1 in seq v $ return $ FloatVal v
liftFVBuiltin1 _ [_] = typeMismatch
liftFVBuiltin1 _ _ = wrongNumArgs

liftFVOp2 :: (Float -> Float -> Float) -> Val -> Val -> Code Val
liftFVOp2 f (FloatVal v1) (FloatVal v2) =
    let v = f v1 v2 in seq v $ return $ FloatVal v
liftFVOp2 _ _             _             = typeMismatch

liftSVOp2 :: (String -> String -> String) -> Val -> Val -> Code Val
liftSVOp2 f (StringVal v1) (StringVal v2) =
    let v = f v1 v2 in seq v $ return $ StringVal v
liftSVOp2 _ _              _              = typeMismatch

liftFSCmpOp2 :: (forall a. Ord a => a -> a -> Bool) -> Val -> Val -> Code Val
liftFSCmpOp2 f v1 v2 = do
    assert (typeOf v1 == typeOf v2) TypeMismatchError
    let v = f v1 v2
    seq v $ return $ boolToVal v

valError :: RuntimeError -> Code Val
  The return ( FloatVal 0 ) will never be executed , but is needed to make the types work out .
valError err = raiseRuntimeError err >> return (FloatVal 0)

wrongNumArgs, typeMismatch, invalidArgument, divisionByZero :: Code Val
wrongNumArgs    = valError WrongNumberOfArgumentsError
typeMismatch    = valError TypeMismatchError
invalidArgument = valError InvalidArgumentError
divisionByZero  = valError DivisionByZeroError

-- | Evaluate a BASIC expression.
eval :: Expr -> Code Val
eval (LitX (FloatLit v)) = return (FloatVal v)
eval (LitX (StringLit v)) = return (StringVal v)
eval (VarX var) = getVar var
eval (FnX var xs) = do
    fn <- getFn var
    vals <- mapM eval xs
    fn vals
eval (MinusX x) = do
    val <- eval x
    liftFVOp1 negate val
eval (NotX x) = do
    val <- eval x
    liftFVOp1 (\v -> if v==0 then -1 else 0) val
eval (BinX op x1 x2) = do
    v1 <- eval x1
    v2 <- eval x2
    evalBinOp op v1 v2
eval (BuiltinX b xs) = do
    vs <- mapM eval xs
    evalBuiltin b vs
eval NextZoneX = do
    curCol <- getOutputColumn
    let numSpaces = zoneWidth - (curCol `mod` zoneWidth)
    return $ StringVal $ replicate numSpaces ' '
eval EmptySeparatorX = return $ StringVal ""
eval (ParenX x) = eval x

-- | Evaluate an expression with a binary operator.
evalBinOp :: BinOp -> Val -> Val -> Code Val
evalBinOp op =
    case op of
        AddOp -> \v1 v2 ->
            case (v1,v2) of
                (FloatVal _,  FloatVal _ ) -> liftFVOp2 (+) v1 v2
                (StringVal _, StringVal _) -> liftSVOp2 (++) v1 v2
                (_,           _          ) -> typeMismatch
        SubOp -> liftFVOp2 (-)
        MulOp -> liftFVOp2 (*)
        DivOp -> \v1 v2 ->
            case (v1,v2) of
                (FloatVal fv1, FloatVal fv2) ->
                    if fv2==0
                        then divisionByZero
                        else let v = fv1/fv2 in seq v $ return $ FloatVal v
                (_,_) -> typeMismatch
        PowOp -> liftFVOp2 (**)
        EqOp -> liftFSCmpOp2 (==)
        NEOp -> liftFSCmpOp2 (/=)
        LTOp -> liftFSCmpOp2 (<)
        LEOp -> liftFSCmpOp2 (<=)
        GTOp -> liftFSCmpOp2 (>)
        GEOp -> liftFSCmpOp2 (>=)
        AndOp -> liftFVOp2 $ \v1 v2 -> if v1/=0 && v2/=0 then v1 else 0
        OrOp -> liftFVOp2 $ \v1 v2 -> if v1/=0 then v1 else v2

checkArgTypes :: [ValType] -> [Val] -> Code ()
checkArgTypes types vals = do
    if length types == length vals
        then
            if and [t == typeOf v | t <- types | v <- vals]
                then return ()
                else typeMismatch >> return ()
        else
            wrongNumArgs >> return ()

-- | Evaluate an expression with a builtin function.
evalBuiltin :: Builtin -> [Val] -> Code Val
evalBuiltin builtin args = case builtin of
    AbsBI -> liftFVBuiltin1 abs args
    AscBI -> do
        checkArgTypes [StringType] args
        let [StringVal v] = args
        if length v == 0
            then invalidArgument
            else return $ FloatVal (fromIntegral (fromEnum (head v)))
    AtnBI -> liftFVBuiltin1 atan args
    ChrBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal v] = args
        let iv = floatToInt v
        if iv < 0 || iv > 255
            then invalidArgument
            else return $ StringVal [toEnum iv]
    CosBI -> liftFVBuiltin1 cos args
    ExpBI -> liftFVBuiltin1 exp args
    IntBI -> liftFVBuiltin1 (fromIntegral . floatToInt) args
    LeftBI -> do
        checkArgTypes [StringType, FloatType] args
        let [StringVal sv, FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
            then invalidArgument
            else return (StringVal (take iv sv))
    LenBI -> do
        checkArgTypes [StringType] args
        let [StringVal sv] = args in return (FloatVal (fromIntegral (length sv)))
    LogBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args in if fv <= 0 then invalidArgument else return (FloatVal (log fv))
    MidBI -> case args of
        [StringVal sv, FloatVal fv] ->
            let iv = floatToInt fv in
                if iv < 1
                    then invalidArgument
                    else return (StringVal (drop (iv-1) sv))
        [_, _] -> typeMismatch
        [StringVal sv, FloatVal fv1, FloatVal fv2] ->
            let iv1 = floatToInt fv1
                iv2 = floatToInt fv2
            in
                if iv1 < 1 || iv2 < 0
                    then invalidArgument
                    else return (StringVal (take iv2 (drop (iv1-1) sv)))
        [_, _, _] -> typeMismatch
        _ -> wrongNumArgs
    RightBI -> do
        checkArgTypes [StringType, FloatType] args
        let [StringVal sv, FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
            then invalidArgument
            else return (StringVal (drop (length sv - iv) sv))
    RndBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
            then seedRandom iv
            else return ()
        rv <- if (iv == 0) then getPrevRandom else getRandom
        return (FloatVal rv)
    SgnBI -> liftFVBuiltin1 (\v -> if v < 0 then -1 else if v > 0 then 1 else 0) args
    SinBI -> liftFVBuiltin1 sin args
    SpcBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
           then invalidArgument
           else return (StringVal (replicate iv ' '))
    SqrBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        if fv < 0
            then invalidArgument
            else return (FloatVal (sqrt fv))
    StrBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args in return (StringVal (showVal (FloatVal fv)))
    TabBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        let destCol = floatToInt fv
        if (destCol < 0)
          then invalidArgument
          else do
            curCol <- getOutputColumn
            return $ StringVal $
                if curCol > destCol
                  then ""
                  else replicate (destCol - curCol) ' '
    TanBI -> liftFVBuiltin1 tan args
    ValBI -> do
        checkArgTypes [StringType] args
        let [StringVal sv] = args in return (FloatVal (maybe 0 id (readFloat (trim sv))))

-- | Interpret a tagged statement.
-- Sets the line number in the state, then passes the statement on to interpS.
interpTS :: JumpTable -> Tagged Statement -> Code ()
interpTS jumpTable (Tagged pos statement) = do
    setLineNumber (sourceLine pos)
    interpS jumpTable statement

-- | Interpret a single statement.
  In the type of interpS , the first ( ) signifies what is passed to a
  resumed trap .   The second one represents what is returned by interpS.
interpS :: JumpTable -> Statement -> Code ()

interpS _ (RemS _) = return ()

interpS _ EndS = end

interpS _ StopS = end

interpS _ (DimS arrs) = mapM_ interpDim arrs

interpS _ (LetS var x) = do
    val <- eval x
    setVar var val

interpS _ (PrintS xs) = do
    _ <- mapM (\x -> eval x >>= printVal) xs
    if null xs || not (isPrintSeparator (last xs))
        then printString "\n"
        else return ()

interpS _ (InputS mPrompt vars) = do
    case mPrompt of
        Nothing -> return ()
        (Just ps) -> printString ps
    inputVars vars

interpS jumpTable (GotoS lab) = do
    let maybeCode = programLookup jumpTable lab
    assert (isJust maybeCode) (BadGotoTargetError lab)
    fromJust maybeCode >> end

interpS jumpTable (OnGotoS x labs) = interpComputed jumpTable GotoS x labs

interpS jumpTable (OnGosubS x labs) = interpComputed jumpTable GosubS x labs

interpS jumpTable (IfS x sts) = do
    v <- eval x
    fv <- extractFloatOrFail TypeMismatchError v
    if fv == 0
        then return ()
        else mapM_ (interpTS jumpTable) sts

  Note that the loop condition is n't tested until a NEXT is reached .
-- This is an intentionally authentic feature.  In fact, were we to try to
  test at the initial FOR , we would n't know which NEXT to jump to to skip
-- the loop - it is undecidable.
interpS _ (ForS control x1 x2 x3) = do
    assert (typeOf control == FloatType) TypeMismatchError
    v1 <- eval x1
    _ <- extractFloatOrFail TypeMismatchError v1
    setScalarVar control v1
    v2 <- eval x2
    lim <- extractFloatOrFail TypeMismatchError v2
    v3 <- eval x3
    step <- extractFloatOrFail TypeMismatchError v3
    trap $ \ x passOn resume continue ->
        if isNext x || isNextVar control x
            then do
                indexVal <- getScalarVar control
                let index = case indexVal of
                        FloatVal i -> i
                        _ -> error "expected float val for FOR index"
                    index' = index+step
                setScalarVar control (FloatVal index')
                if (step>=0 && index'<=lim)
                    || (step<0 && index'>=lim)
                    then continue True
                    else resume False
            else passOn True

interpS _ (NextS Nothing) = raiseRuntimeException (Next Nothing)
interpS _ (NextS (Just vars)) = mapM_ interpNextVar vars

interpS jumpTable (GosubS lab) =
    do let maybeCode = programLookup jumpTable lab
       assert (isJust maybeCode) (BadGosubTargetError lab)
       _ <- catchC gosubHandler (fromJust maybeCode)
       return ()
interpS _ ReturnS = raiseRuntimeException Return

interpS _ RandomizeS = seedRandomFromTime

interpS jumpTable (RestoreS maybeLab) = do
   case maybeLab of
       (Just lab) -> case dataLookup jumpTable lab of
           (Just ds) -> setDataStrings ds
           Nothing -> raiseRuntimeError (BadRestoreTargetError lab)
       Nothing -> if null jumpTable
           then return ()
           else setDataStrings (jtData (head jumpTable))

interpS _ (ReadS vars) = mapM_ interpRead vars

interpS _ (DataS _) = return ()

interpS _ (DefFnS vn params expr) = setFn vn $ \vals -> do
    assert (length params == length vals) WrongNumberOfArgumentsError
    assert
        (and [typeOf p == typeOf v | p <- params | v <- vals])
        TypeMismatchError
    stashedVals <- mapM getScalarVar params
    sequence_ $ zipWith setScalarVar params vals
    result <- eval expr
    sequence_ $ zipWith setScalarVar params stashedVals
    return result

gosubHandler :: BasicExceptionHandler
gosubHandler x passOn _ continue = if isReturn x then continue False else passOn True

-- | Interpret a computed @GOTO@ or @GOSUB@.
interpComputed :: JumpTable -> (Label -> Statement) -> Expr -> [Label] -> Code ()
interpComputed jumpTable cons x labs = do
    v <- eval x
    fv <- extractFloatOrFail TypeMismatchError v
    let i = floatToInt fv
    if i > 0 && i <= length labs
        then do
            let lab = labs !! (i-1)
            interpS jumpTable (cons lab)
        else
            return ()

-- | Interpret a @NEXT@ with a supplied variable.
interpNextVar :: VarName -> Code ()
interpNextVar (VarName FloatType v) = raiseRuntimeException (Next (Just v))
interpNextVar _ = raiseRuntimeError TypeMismatchError

-- | Execute an @INPUT@ statement with a list of input variables.
inputVars :: [Var] -> Code ()
inputVars vars = do
    printString "? "
    inText <- getString
    case parse dataValsP "" inText of
        (Right ivs) -> do
            let maybeVals = zipWith checkInput vars ivs
            if or (map isNothing maybeVals)
                then do
                    printString "!NUMBER EXPECTED - RETRY INPUT LINE\n"
                    inputVars vars
                else do
                    let vals = map fromJust maybeVals
                    sequence_ (zipWith setVar vars vals)
                    case compare (length vars) (length ivs) of
                        LT -> printString "!EXTRA INPUT IGNORED\n"
                        GT -> do
                            printString "?"
                            inputVars (drop (length vals) vars)
                        EQ -> return ()
        (Left _) -> error "Mismatched inputbuf in inputVars"

checkInput :: Var -> String -> Maybe Val
checkInput var s = case typeOf var of
    StringType -> Just (StringVal s)
    FloatType  -> case readFloat s of
        (Just v) -> Just (FloatVal v)
        _ -> Nothing
    IntType -> case readFloat s of
        (Just v) -> Just (IntVal (floatToInt v))
        _ -> Nothing

interpRead :: Var -> Code ()
interpRead var = do
    s <- readData
    case checkInput var s of
        Nothing -> raiseRuntimeError TypeMismatchError
        (Just val) -> setVar var val

getVar :: Var -> Code Val
getVar (ScalarVar vn) = do
    val <- getScalarVar vn
    coerceToExpression val
getVar (ArrVar vn xs) = do
    inds <- mapM eval xs
    is <- checkArrInds inds
    val <- getArrVar vn is
    coerceToExpression val

setVar :: Var -> Val -> Code ()
setVar (ScalarVar vn) val = do
    val' <- coerce vn val
    setScalarVar vn val'
setVar (ArrVar vn xs) val = do
    inds <- mapM eval xs
    is <- checkArrInds inds
    val' <- coerce vn val
    setArrVar vn is val'

-- | Coerce a value to the type it would have in an expression.
-- Specifically coerces ints to floats.
coerceToExpression :: Val -> Code Val
coerceToExpression val = case typeOf val of
    IntType -> coerce FloatType val
    _       -> return val

coerce :: Typeable a => a -> Val -> Code Val
coerce var val = case (typeOf var, val) of
    (IntType,    (FloatVal fv)) -> return $ IntVal (floatToInt fv)
    (FloatType,  (FloatVal _))  -> return val
    (FloatType,  (IntVal iv))   -> return $ FloatVal (fromIntegral iv)
    (IntType,    (IntVal _))    -> return val
    (StringType, (StringVal _)) -> return val
    (_,          _)             -> typeMismatch

interpDim :: (VarName, [Expr]) -> Code ()
interpDim (vn, xs) = do
    inds <- mapM eval xs
    is <- checkArrInds inds
  add 1 , so that range is from 0 to user - specified bound
    let bounds = map (1+) is
    _ <- dimArray vn bounds
    return ()

checkArrInds :: [Val] -> Basic (BasicExcep Result ()) [Int]
checkArrInds indVals = do
    indFs <- mapM (extractFloatOrFail TypeMismatchError) indVals
    assert (and (map (>=0) indFs)) NegativeArrayDimError
    let inds = map floatToInt indFs
    return inds

showVal :: Val -> String
showVal (FloatVal fv) = printFloat fv
showVal (IntVal iv) = if iv > 0 then " " else "" ++ show iv
showVal (StringVal s) = s

printVal :: Val -> Basic o ()
printVal v =
  printString (showVal v ++ case v of
      (FloatVal _)  -> " "
      (IntVal _)    -> " "
      (StringVal _) -> ""
  )

-- | Extract the @DATA@ strings from a program line.
dataFromLine :: Line -> [String]
dataFromLine (Line _ stmts) = concat (map (dataFromStatement . getTaggedVal) stmts)

dataFromStatement :: Statement -> [String]
dataFromStatement (DataS s) =
    let (Right ss) = parse dataValsP "" s
    in ss
dataFromStatement _ = []

 | The heart of the BASIC interpreter. It is implemented on top
 of the BASIC monad.
 | Entry in the jump table, a lookup table that holds both
 program code and @DATA@ statements, indexed by 'Label'.
 ^ the starting line number
 ^ program source starting at that line
 ^ @DATA@ strings starting at that line
 | Lazily interprets a list of BASIC lines of code.
 Note that jumpTable and interpLine are mutually recursive.
 The jumpTable contains interpreted code, which in turn calls
 the jumpTable to look up code.  Since the jumpTable is a single
 data structure, it memoizes interpreted code, making 'interpLines'
 a just-in-time compiler.  (The only time code is reinterpreted
 is following an @IF@ statement.)
 Expression evaluation
 | Evaluate a BASIC expression.
 | Evaluate an expression with a binary operator.
 | Evaluate an expression with a builtin function.
 | Interpret a tagged statement.
 Sets the line number in the state, then passes the statement on to interpS.
 | Interpret a single statement.
 This is an intentionally authentic feature.  In fact, were we to try to
 the loop - it is undecidable.
 | Interpret a computed @GOTO@ or @GOSUB@.
 | Interpret a @NEXT@ with a supplied variable.
 | Execute an @INPUT@ statement with a list of input variables.
 | Coerce a value to the type it would have in an expression.
 Specifically coerces ints to floats.
 | Extract the @DATA@ strings from a program line.
# LANGUAGE FlexibleContexts , ParallelListComp , Rank2Types #


module Language.VintageBasic.Interpreter(interpLines) where

import Control.Monad.CPST.DurableTraps
import Data.List
import Data.Maybe
import Language.VintageBasic.Builtins(Builtin(..))
import Language.VintageBasic.LexCommon(Tagged(..))
import Language.VintageBasic.BasicMonad
import Language.VintageBasic.Result
import Language.VintageBasic.Printer(printFloat)
import Language.VintageBasic.RuntimeParser(dataValsP,readFloat,trim)
import Language.VintageBasic.Syntax
import Text.ParserCombinators.Parsec(parse)
import Text.ParserCombinators.Parsec.Pos(sourceLine)

data JumpTableEntry = JumpTableEntry {
}

type JumpTable = [JumpTableEntry]

programLookup :: JumpTable -> Label -> (Maybe Program)
programLookup jt lab = lookup lab [(jtLabel jte, jtProgram jte) | jte <- jt]

dataLookup :: JumpTable -> Label -> (Maybe [String])
dataLookup jt lab = lookup lab [(jtLabel jte, jtData jte) | jte <- jt]


interpLines :: [Line] -> Program


interpLines progLines =
    let interpLine line@(Line lab stmts) =
            (lab, mapM_ (interpTS jumpTable) stmts, dataFromLine line)
        makeTableEntry (accumCode, accumData) (lab, codeSeg, lineData) =
            let accumCode' = codeSeg >> accumCode
                accumData' = lineData ++ accumData
                in ((accumCode', accumData'), JumpTableEntry lab accumCode' accumData')
        jumpTable = snd $ mapAccumR makeTableEntry (done, []) $ map interpLine progLines
    in do
        case jumpTable of
            ((JumpTableEntry _ prog dat) : _) -> do
                seedRandomFromTime
                setDataStrings dat
                prog
            [] -> done


boolToVal :: Bool -> Val
boolToVal t = if t then FloatVal (-1) else FloatVal 0

isNext :: Result -> Bool
isNext (LabeledRuntimeException _ (Next Nothing)) = True
isNext _ = False

isNextVar :: VarName -> Result -> Bool
isNextVar (VarName FloatType v1) (LabeledRuntimeException _ (Next (Just v2))) = v1==v2
isNextVar _ _ = False

isReturn :: Result -> Bool
isReturn (LabeledRuntimeException _ Return) = True
isReturn _ = False

liftFVOp1 :: (Float -> Float) -> Val -> Code Val
liftFVOp1 f (FloatVal v1) =
    let v = f v1 in seq v $ return $ FloatVal v
liftFVOp1 _ _             = typeMismatch

liftFVBuiltin1 :: (Float -> Float) -> [Val] -> Code Val
liftFVBuiltin1 f [FloatVal v1] =
    let v = f v1 in seq v $ return $ FloatVal v
liftFVBuiltin1 _ [_] = typeMismatch
liftFVBuiltin1 _ _ = wrongNumArgs

liftFVOp2 :: (Float -> Float -> Float) -> Val -> Val -> Code Val
liftFVOp2 f (FloatVal v1) (FloatVal v2) =
    let v = f v1 v2 in seq v $ return $ FloatVal v
liftFVOp2 _ _             _             = typeMismatch

liftSVOp2 :: (String -> String -> String) -> Val -> Val -> Code Val
liftSVOp2 f (StringVal v1) (StringVal v2) =
    let v = f v1 v2 in seq v $ return $ StringVal v
liftSVOp2 _ _              _              = typeMismatch

liftFSCmpOp2 :: (forall a. Ord a => a -> a -> Bool) -> Val -> Val -> Code Val
liftFSCmpOp2 f v1 v2 = do
    assert (typeOf v1 == typeOf v2) TypeMismatchError
    let v = f v1 v2
    seq v $ return $ boolToVal v

valError :: RuntimeError -> Code Val
  The return ( FloatVal 0 ) will never be executed , but is needed to make the types work out .
valError err = raiseRuntimeError err >> return (FloatVal 0)

wrongNumArgs, typeMismatch, invalidArgument, divisionByZero :: Code Val
wrongNumArgs    = valError WrongNumberOfArgumentsError
typeMismatch    = valError TypeMismatchError
invalidArgument = valError InvalidArgumentError
divisionByZero  = valError DivisionByZeroError

eval :: Expr -> Code Val
eval (LitX (FloatLit v)) = return (FloatVal v)
eval (LitX (StringLit v)) = return (StringVal v)
eval (VarX var) = getVar var
eval (FnX var xs) = do
    fn <- getFn var
    vals <- mapM eval xs
    fn vals
eval (MinusX x) = do
    val <- eval x
    liftFVOp1 negate val
eval (NotX x) = do
    val <- eval x
    liftFVOp1 (\v -> if v==0 then -1 else 0) val
eval (BinX op x1 x2) = do
    v1 <- eval x1
    v2 <- eval x2
    evalBinOp op v1 v2
eval (BuiltinX b xs) = do
    vs <- mapM eval xs
    evalBuiltin b vs
eval NextZoneX = do
    curCol <- getOutputColumn
    let numSpaces = zoneWidth - (curCol `mod` zoneWidth)
    return $ StringVal $ replicate numSpaces ' '
eval EmptySeparatorX = return $ StringVal ""
eval (ParenX x) = eval x

evalBinOp :: BinOp -> Val -> Val -> Code Val
evalBinOp op =
    case op of
        AddOp -> \v1 v2 ->
            case (v1,v2) of
                (FloatVal _,  FloatVal _ ) -> liftFVOp2 (+) v1 v2
                (StringVal _, StringVal _) -> liftSVOp2 (++) v1 v2
                (_,           _          ) -> typeMismatch
        SubOp -> liftFVOp2 (-)
        MulOp -> liftFVOp2 (*)
        DivOp -> \v1 v2 ->
            case (v1,v2) of
                (FloatVal fv1, FloatVal fv2) ->
                    if fv2==0
                        then divisionByZero
                        else let v = fv1/fv2 in seq v $ return $ FloatVal v
                (_,_) -> typeMismatch
        PowOp -> liftFVOp2 (**)
        EqOp -> liftFSCmpOp2 (==)
        NEOp -> liftFSCmpOp2 (/=)
        LTOp -> liftFSCmpOp2 (<)
        LEOp -> liftFSCmpOp2 (<=)
        GTOp -> liftFSCmpOp2 (>)
        GEOp -> liftFSCmpOp2 (>=)
        AndOp -> liftFVOp2 $ \v1 v2 -> if v1/=0 && v2/=0 then v1 else 0
        OrOp -> liftFVOp2 $ \v1 v2 -> if v1/=0 then v1 else v2

checkArgTypes :: [ValType] -> [Val] -> Code ()
checkArgTypes types vals = do
    if length types == length vals
        then
            if and [t == typeOf v | t <- types | v <- vals]
                then return ()
                else typeMismatch >> return ()
        else
            wrongNumArgs >> return ()

evalBuiltin :: Builtin -> [Val] -> Code Val
evalBuiltin builtin args = case builtin of
    AbsBI -> liftFVBuiltin1 abs args
    AscBI -> do
        checkArgTypes [StringType] args
        let [StringVal v] = args
        if length v == 0
            then invalidArgument
            else return $ FloatVal (fromIntegral (fromEnum (head v)))
    AtnBI -> liftFVBuiltin1 atan args
    ChrBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal v] = args
        let iv = floatToInt v
        if iv < 0 || iv > 255
            then invalidArgument
            else return $ StringVal [toEnum iv]
    CosBI -> liftFVBuiltin1 cos args
    ExpBI -> liftFVBuiltin1 exp args
    IntBI -> liftFVBuiltin1 (fromIntegral . floatToInt) args
    LeftBI -> do
        checkArgTypes [StringType, FloatType] args
        let [StringVal sv, FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
            then invalidArgument
            else return (StringVal (take iv sv))
    LenBI -> do
        checkArgTypes [StringType] args
        let [StringVal sv] = args in return (FloatVal (fromIntegral (length sv)))
    LogBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args in if fv <= 0 then invalidArgument else return (FloatVal (log fv))
    MidBI -> case args of
        [StringVal sv, FloatVal fv] ->
            let iv = floatToInt fv in
                if iv < 1
                    then invalidArgument
                    else return (StringVal (drop (iv-1) sv))
        [_, _] -> typeMismatch
        [StringVal sv, FloatVal fv1, FloatVal fv2] ->
            let iv1 = floatToInt fv1
                iv2 = floatToInt fv2
            in
                if iv1 < 1 || iv2 < 0
                    then invalidArgument
                    else return (StringVal (take iv2 (drop (iv1-1) sv)))
        [_, _, _] -> typeMismatch
        _ -> wrongNumArgs
    RightBI -> do
        checkArgTypes [StringType, FloatType] args
        let [StringVal sv, FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
            then invalidArgument
            else return (StringVal (drop (length sv - iv) sv))
    RndBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
            then seedRandom iv
            else return ()
        rv <- if (iv == 0) then getPrevRandom else getRandom
        return (FloatVal rv)
    SgnBI -> liftFVBuiltin1 (\v -> if v < 0 then -1 else if v > 0 then 1 else 0) args
    SinBI -> liftFVBuiltin1 sin args
    SpcBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        let iv = floatToInt fv
        if iv < 0
           then invalidArgument
           else return (StringVal (replicate iv ' '))
    SqrBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        if fv < 0
            then invalidArgument
            else return (FloatVal (sqrt fv))
    StrBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args in return (StringVal (showVal (FloatVal fv)))
    TabBI -> do
        checkArgTypes [FloatType] args
        let [FloatVal fv] = args
        let destCol = floatToInt fv
        if (destCol < 0)
          then invalidArgument
          else do
            curCol <- getOutputColumn
            return $ StringVal $
                if curCol > destCol
                  then ""
                  else replicate (destCol - curCol) ' '
    TanBI -> liftFVBuiltin1 tan args
    ValBI -> do
        checkArgTypes [StringType] args
        let [StringVal sv] = args in return (FloatVal (maybe 0 id (readFloat (trim sv))))

interpTS :: JumpTable -> Tagged Statement -> Code ()
interpTS jumpTable (Tagged pos statement) = do
    setLineNumber (sourceLine pos)
    interpS jumpTable statement

  In the type of interpS , the first ( ) signifies what is passed to a
  resumed trap .   The second one represents what is returned by interpS.
interpS :: JumpTable -> Statement -> Code ()

interpS _ (RemS _) = return ()

interpS _ EndS = end

interpS _ StopS = end

interpS _ (DimS arrs) = mapM_ interpDim arrs

interpS _ (LetS var x) = do
    val <- eval x
    setVar var val

interpS _ (PrintS xs) = do
    _ <- mapM (\x -> eval x >>= printVal) xs
    if null xs || not (isPrintSeparator (last xs))
        then printString "\n"
        else return ()

interpS _ (InputS mPrompt vars) = do
    case mPrompt of
        Nothing -> return ()
        (Just ps) -> printString ps
    inputVars vars

interpS jumpTable (GotoS lab) = do
    let maybeCode = programLookup jumpTable lab
    assert (isJust maybeCode) (BadGotoTargetError lab)
    fromJust maybeCode >> end

interpS jumpTable (OnGotoS x labs) = interpComputed jumpTable GotoS x labs

interpS jumpTable (OnGosubS x labs) = interpComputed jumpTable GosubS x labs

interpS jumpTable (IfS x sts) = do
    v <- eval x
    fv <- extractFloatOrFail TypeMismatchError v
    if fv == 0
        then return ()
        else mapM_ (interpTS jumpTable) sts

  Note that the loop condition is n't tested until a NEXT is reached .
  test at the initial FOR , we would n't know which NEXT to jump to to skip
interpS _ (ForS control x1 x2 x3) = do
    assert (typeOf control == FloatType) TypeMismatchError
    v1 <- eval x1
    _ <- extractFloatOrFail TypeMismatchError v1
    setScalarVar control v1
    v2 <- eval x2
    lim <- extractFloatOrFail TypeMismatchError v2
    v3 <- eval x3
    step <- extractFloatOrFail TypeMismatchError v3
    trap $ \ x passOn resume continue ->
        if isNext x || isNextVar control x
            then do
                indexVal <- getScalarVar control
                let index = case indexVal of
                        FloatVal i -> i
                        _ -> error "expected float val for FOR index"
                    index' = index+step
                setScalarVar control (FloatVal index')
                if (step>=0 && index'<=lim)
                    || (step<0 && index'>=lim)
                    then continue True
                    else resume False
            else passOn True

interpS _ (NextS Nothing) = raiseRuntimeException (Next Nothing)
interpS _ (NextS (Just vars)) = mapM_ interpNextVar vars

interpS jumpTable (GosubS lab) =
    do let maybeCode = programLookup jumpTable lab
       assert (isJust maybeCode) (BadGosubTargetError lab)
       _ <- catchC gosubHandler (fromJust maybeCode)
       return ()
interpS _ ReturnS = raiseRuntimeException Return

interpS _ RandomizeS = seedRandomFromTime

interpS jumpTable (RestoreS maybeLab) = do
   case maybeLab of
       (Just lab) -> case dataLookup jumpTable lab of
           (Just ds) -> setDataStrings ds
           Nothing -> raiseRuntimeError (BadRestoreTargetError lab)
       Nothing -> if null jumpTable
           then return ()
           else setDataStrings (jtData (head jumpTable))

interpS _ (ReadS vars) = mapM_ interpRead vars

interpS _ (DataS _) = return ()

interpS _ (DefFnS vn params expr) = setFn vn $ \vals -> do
    assert (length params == length vals) WrongNumberOfArgumentsError
    assert
        (and [typeOf p == typeOf v | p <- params | v <- vals])
        TypeMismatchError
    stashedVals <- mapM getScalarVar params
    sequence_ $ zipWith setScalarVar params vals
    result <- eval expr
    sequence_ $ zipWith setScalarVar params stashedVals
    return result

gosubHandler :: BasicExceptionHandler
gosubHandler x passOn _ continue = if isReturn x then continue False else passOn True

interpComputed :: JumpTable -> (Label -> Statement) -> Expr -> [Label] -> Code ()
interpComputed jumpTable cons x labs = do
    v <- eval x
    fv <- extractFloatOrFail TypeMismatchError v
    let i = floatToInt fv
    if i > 0 && i <= length labs
        then do
            let lab = labs !! (i-1)
            interpS jumpTable (cons lab)
        else
            return ()

interpNextVar :: VarName -> Code ()
interpNextVar (VarName FloatType v) = raiseRuntimeException (Next (Just v))
interpNextVar _ = raiseRuntimeError TypeMismatchError

inputVars :: [Var] -> Code ()
inputVars vars = do
    printString "? "
    inText <- getString
    case parse dataValsP "" inText of
        (Right ivs) -> do
            let maybeVals = zipWith checkInput vars ivs
            if or (map isNothing maybeVals)
                then do
                    printString "!NUMBER EXPECTED - RETRY INPUT LINE\n"
                    inputVars vars
                else do
                    let vals = map fromJust maybeVals
                    sequence_ (zipWith setVar vars vals)
                    case compare (length vars) (length ivs) of
                        LT -> printString "!EXTRA INPUT IGNORED\n"
                        GT -> do
                            printString "?"
                            inputVars (drop (length vals) vars)
                        EQ -> return ()
        (Left _) -> error "Mismatched inputbuf in inputVars"

checkInput :: Var -> String -> Maybe Val
checkInput var s = case typeOf var of
    StringType -> Just (StringVal s)
    FloatType  -> case readFloat s of
        (Just v) -> Just (FloatVal v)
        _ -> Nothing
    IntType -> case readFloat s of
        (Just v) -> Just (IntVal (floatToInt v))
        _ -> Nothing

interpRead :: Var -> Code ()
interpRead var = do
    s <- readData
    case checkInput var s of
        Nothing -> raiseRuntimeError TypeMismatchError
        (Just val) -> setVar var val

getVar :: Var -> Code Val
getVar (ScalarVar vn) = do
    val <- getScalarVar vn
    coerceToExpression val
getVar (ArrVar vn xs) = do
    inds <- mapM eval xs
    is <- checkArrInds inds
    val <- getArrVar vn is
    coerceToExpression val

setVar :: Var -> Val -> Code ()
setVar (ScalarVar vn) val = do
    val' <- coerce vn val
    setScalarVar vn val'
setVar (ArrVar vn xs) val = do
    inds <- mapM eval xs
    is <- checkArrInds inds
    val' <- coerce vn val
    setArrVar vn is val'

coerceToExpression :: Val -> Code Val
coerceToExpression val = case typeOf val of
    IntType -> coerce FloatType val
    _       -> return val

coerce :: Typeable a => a -> Val -> Code Val
coerce var val = case (typeOf var, val) of
    (IntType,    (FloatVal fv)) -> return $ IntVal (floatToInt fv)
    (FloatType,  (FloatVal _))  -> return val
    (FloatType,  (IntVal iv))   -> return $ FloatVal (fromIntegral iv)
    (IntType,    (IntVal _))    -> return val
    (StringType, (StringVal _)) -> return val
    (_,          _)             -> typeMismatch

interpDim :: (VarName, [Expr]) -> Code ()
interpDim (vn, xs) = do
    inds <- mapM eval xs
    is <- checkArrInds inds
  add 1 , so that range is from 0 to user - specified bound
    let bounds = map (1+) is
    _ <- dimArray vn bounds
    return ()

checkArrInds :: [Val] -> Basic (BasicExcep Result ()) [Int]
checkArrInds indVals = do
    indFs <- mapM (extractFloatOrFail TypeMismatchError) indVals
    assert (and (map (>=0) indFs)) NegativeArrayDimError
    let inds = map floatToInt indFs
    return inds

showVal :: Val -> String
showVal (FloatVal fv) = printFloat fv
showVal (IntVal iv) = if iv > 0 then " " else "" ++ show iv
showVal (StringVal s) = s

printVal :: Val -> Basic o ()
printVal v =
  printString (showVal v ++ case v of
      (FloatVal _)  -> " "
      (IntVal _)    -> " "
      (StringVal _) -> ""
  )

dataFromLine :: Line -> [String]
dataFromLine (Line _ stmts) = concat (map (dataFromStatement . getTaggedVal) stmts)

dataFromStatement :: Statement -> [String]
dataFromStatement (DataS s) =
    let (Right ss) = parse dataValsP "" s
    in ss
dataFromStatement _ = []
