Exec.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module      : Angle.Exec.Exec
Description : Controls execution of an Angle program.
Copyright   : Copyright (C) 2015 Ben Moon
License     : GNU GPL, version 3
Maintainer  : GuiltyDolphin@gmail.com
Stability   : alpha

All programs in Angle can be expressed as a single statement
(usually a multi-statement) and as such all programs are executed
via this one statement.
-}
module Angle.Exec.Exec
    ( execStmt
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (isNothing, fromMaybe)
import System.Directory (findFile, canonicalizePath)
import System.FilePath (takeDirectory)

import Angle.Parse.Parser (program, evalParse)
import Angle.Exec.Builtins
import Angle.Exec.Error
import Angle.Exec.Operations
import Angle.Exec.Scope
import Angle.Exec.Types
import Angle.Types.Lang
import Angle.Types.Scope


bindArgs :: [Expr] -> ArgSig -> ExecIO ()
bindArgs args (ArgSig
                    { stdArgs=params
                    , catchAllArg=catchParam})
    = do
  let toCheck = zip args params
      la = length args
      lp = length params
  when ((la > lp && isNothing catchParam) || la < lp)
           (throwExecError $ wrongNumberOfArgumentsErr lp la)
  catchBind <- case catchParam of
                 Nothing -> return []
                 Just cp -> do
                   let toCatch = drop lp args
                   res <- mapM execExpr toCatch
                   return [(catchArgName cp, LitList res)]
  vals <- mapM (uncurry checkArg) toCheck
  case catchParam of
      Nothing -> return ()
      Just catcher ->
          case catchArgConstr catcher of
               Nothing -> return ()
               Just (ConstrRef cstr constrArgs) ->
                   case catchBind of
                        [] -> return ()
                        [(_, r)] -> checkSatConstr r (Just cstr) (fromMaybe [] constrArgs)
                        _ -> undefined
  let toBindFuns = map fst $ filter (isAnnFun . snd)  vals
      toBindLits = map fst $ filter (isAnnLit . snd) vals
      toBindAny = map fst (filter (isAnnAny . snd) vals) ++ catchBind
      isAnnFun AnnFun = True
      isAnnFun _ = False
      isAnnLit AnnLit = True
      isAnnLit _ = False
      isAnnAny AnnAny = True
      isAnnAny _ = False
  newScope
  forM_ toBindFuns (\(x, LitLambda l) -> assignVarFunLocal x l)
  forM_ toBindLits (uncurry assignVarLitLocal)
  forM_ toBindAny (uncurry assignVarLitLocal)
  return ()


-- | Make sure the argument satisfies any
-- class or type restrictions placed upon it.
checkArg :: Expr -> ArgElt -> ExecIO ((LangIdent, LangLit), AnnType)
checkArg ex (ArgElt {argEltConstr=constr, argEltType=typ
                    , argEltName=name}) = do
  v <- execExpr ex
  let cstr = fmap getConstrRef constr
  checkSatConstr v cstr (fromMaybe [] $ maybe Nothing constrRefArgs constr)
  checkSatType v typ
  return ((name, v), typ)


checkSatConstr :: LangLit -> Maybe LangIdent -> [Expr] -> ExecIO ()
checkSatConstr _ Nothing _ = return ()
checkSatConstr v (Just clsName) constrArgs = do
  res <- satConstr v clsName constrArgs
  unless res (throwExecError $ typeExpectConstrErr v clsName)


execConstr :: LangLit -> LangIdent -> [Expr] -> ExecIO LangLit
execConstr val clsName args = do
  cls <- lookupVarFunLocal clsName
  res <- callLambda cls True $ ExprLit val : args
  case res of
    x@(LitBool _) -> return x
    y             -> throwExecError
                     $ typeConstrWrongReturnErr clsName (typeOf y)


-- | Sets the 'as_constr' variable to true if the function is
-- being called as a class, and cleans up afterwords.
withClass :: ExecIO a -> ExecIO a
withClass s = do
  assignVarBuiltinLit (LangIdent "as_constr") (LitBool True)
  res <- s `catchAE` (\e -> setClassFalse >> throwAE e)
  setClassFalse
  return res
  where
    setClassFalse = assignVarBuiltinLit (LangIdent "as_constr") (LitBool False)


-- | True if the literal is of the specified annotation type.
satType :: LangLit -> AnnType -> Bool
satType _ AnnAny = True
satType (LitLambda _) AnnFun = True
satType (LitLambda _) AnnLit = False
satType _ AnnLit = True
satType _ _ = False


-- | Fails if @satType@ returns false with the same arguments.
checkSatType :: CanErrorWithPos m => LangLit -> AnnType -> m ()
checkSatType val typ = do
  let res = satType val typ
  unless res $ throwExecError $ typeAnnWrongErr typ $ typeAnnOf val


-- | True if the given constraint returns true when
-- passed the literal.
satConstr :: LangLit -> LangIdent -> [Expr] -> ExecIO Bool
satConstr val clsName constrArgs = do
  (LitBool res) <- execConstr val clsName constrArgs
  return res


-- | Expand any ExprParamExpand expressions in an argument list.
expandParams :: [Expr] -> ExecIO [Expr]
expandParams [] = return []
expandParams (x:xs)
  = case x of
        ExprParamExpand n -> do
            val <- lookupVarLitLocal n
            case val of
              LitList vs -> liftM (map ExprLit vs ++) $ expandParams xs
              _          -> liftM (x:) $ expandParams xs
        _                -> liftM (x:) $ expandParams xs


execExpr :: Expr -> ExecIO LangLit
execExpr (ExprLit x@(LitRange{})) = checkLitRange x >> returnVal x
execExpr (ExprLit (LitClosure lam)) = do
    currScope <- getScope
    returnVal . LitLambda $ lam { lambdaScope = Just currScope }
execExpr (ExprLit x) = returnVal x
execExpr (ExprIdent x) = lookupVarLitLocal x
execExpr (ExprFunIdent x) = liftM LitLambda $ lookupVarFunLocal x
execExpr (ExprOp x) = execOp x
execExpr (ExprFunCall name asClass args) = execFunCall name asClass args
execExpr (ExprList xs) = liftM LitList $ mapM execExpr xs
execExpr (ExprLambdaCall f xs) = callPureLambda f False xs
execExpr x@(ExprRange{}) = do
  r <- execExprRange x
  checkLitRange r
  returnVal r
execExpr _ = undefined



callPureLambda :: Lambda -> Bool -> [Expr] -> ExecIO LangLit
callPureLambda lam asClass exprs = do
    pushEnvCall (LangIdent "LAMBDA")
    res <- callLambda lam asClass exprs
    popEnvCall
    return res


execExprRange :: Expr -> ExecIO LangLit
execExprRange (ExprRange x Nothing Nothing)
    = liftM3 LitRange (execExpr x) (return Nothing) (return Nothing)
execExprRange (ExprRange x (Just y) Nothing)
    = liftM3 LitRange (execExpr x) (liftM Just $ execExpr y) (return Nothing)
execExprRange (ExprRange x Nothing (Just z))
    = liftM3 LitRange (execExpr x) (return Nothing) (liftM Just $ execExpr z)
execExprRange (ExprRange x (Just y) (Just z))
    = liftM3 LitRange (execExpr x) (liftM Just $ execExpr y) (liftM Just $ execExpr z)
execExprRange _ = error "excExprRange: passed non-range expression"


execFunCall :: LangIdent -> Bool -> [Expr] -> ExecIO LangLit
execFunCall = callFun


execOp :: LangOp -> ExecIO LangLit
execOp (SpecOp op expr) = execSpecOp op expr
execOp (MultiOp op exprs) = execMultiOp op exprs


execSpecOp :: Op -> Expr -> ExecIO LangLit
execSpecOp OpNeg x = execExpr x >>= negLit
execSpecOp OpNot x = execExpr x >>= notLit
execSpecOp x _ = throwImplementationErr $ "execSpecOp - not a SpecOp: " ++ show x


execMultiOp :: Op -> [Expr] -> ExecIO LangLit
execMultiOp OpAdd xs       = withMultiOp xs addLit
execMultiOp OpAnd xs       = withMultiOp xs andLit
execMultiOp OpConcat xs    = withMultiOp xs concatLit
execMultiOp OpDiv xs       = withMultiOp xs divLit
execMultiOp OpEq  xs       = withMultiOp xs eqLit
execMultiOp OpExp xs       = withMultiOp xs expLit
execMultiOp OpGreater xs   = withMultiOp xs greaterLit
execMultiOp OpGreaterEq xs = withMultiOp xs greaterEqLit
execMultiOp OpLess xs      = withMultiOp xs lessLit
execMultiOp OpLessEq xs    = withMultiOp xs lessEqLit
execMultiOp OpMult xs      = withMultiOp xs multLit
execMultiOp OpOr xs        = withMultiOp xs orLit
execMultiOp OpSub xs       = withMultiOp xs subLit
execMultiOp (UserOp _) _ = throwImplementationErr "execMultiOp: implement user operators"
execMultiOp x _ = throwImplementationErr $ "execMultiOp - not a multiOp: " ++ show x


withMultiOp :: [Expr] -> ([LangLit] -> ExecIO LangLit) -> ExecIO LangLit
withMultiOp xs f = mapM execExpr xs >>= f


callFun :: LangIdent -> Bool -> [Expr] -> ExecIO LangLit
callFun x asClass args
    | isBuiltin x = callBuiltin x args
    | otherwise = do
        l <- lookupVarFunLocal x
        pushEnvCall x
        res <- callLambda l asClass args
        popEnvCall
        return res


callLambda :: Lambda -> Bool -> [Expr] -> ExecIO LangLit
callLambda l@(Lambda { lambdaScope = (Just s) }) asClass args
    = do
    cScope <- getScope
    modifyScope (const s)
    res <- callLambda l { lambdaScope = Nothing } asClass args
        `catchAE` (\e -> modifyScope (const cScope) >> throwError e)
    modifyScope (const cScope)
    return res
callLambda (Lambda
            { lambdaArgs=params
            , lambdaBody=body}) asClass args
    = do
  fullArgs <- expandParams args
  bindArgs fullArgs params
  let f = if asClass then withClass else id
  res <- f (execStmt body `catchReturn` return)
  upScope
  return res


-- | Executes a single statement.
execStmt :: Stmt -> ExecIO LangLit
execStmt s@(SingleStmt x pos) = updateStmt s >> updatePos pos >> execSingStmt x
execStmt (MultiStmt (x@(SingleStmt (StmtReturn _) _):_)) = execStmt x
execStmt (MultiStmt []) = return LitNull
execStmt (MultiStmt [x]) = execStmt x
execStmt (MultiStmt (x:xs)) = execStmt x >> execStmt (MultiStmt xs)


assignment
    :: (LangIdent -> Lambda -> ExecIO ())
    -> (LangIdent -> LangLit -> ExecIO ())
    -> LangIdent -> Expr -> ExecIO LangLit
assignment aFun aLit name e = execExpr e
    >>= (\x -> case x of
        x'@(LitLambda l) -> aFun name l >> returnVal x'
        x' -> aLit name x' >> returnVal x')


execSingStmt :: SingStmt -> ExecIO LangLit
execSingStmt (StmtAssign name e) = assignment assignVarFunLocal assignVarLitLocal name e
execSingStmt (StmtAssignNonLocal name e) = assignment assignVarFunOuter assignVarLitOuter name e
execSingStmt (StmtAssignGlobal name e) = assignment assignVarFunGlobal assignVarLitGlobal name e
execSingStmt (StmtStruct x) = execLangStruct x
execSingStmt (StmtExpr x) = do
  res <- execExpr x
  setEnvSynRep (showSyn res)
  returnVal res
execSingStmt (StmtComment _) = return LitNull
execSingStmt (StmtReturn x) = execReturn x
execSingStmt (StmtBreak x False) = execBreak x
execSingStmt (StmtBreak _ True) = throwContinue
execSingStmt (StmtRaise e) = raiseException e


execReturn :: Expr -> ExecIO LangLit
execReturn x = do
  isGlob <- liftM (isOutermostScope . currentScope) getEnv
  if isGlob
      then throwExecError returnFromGlobalErr
      else do
          res <- execExpr x
          case res of
              LitLambda lam -> do
                  sc <- getScope
                  let newS = case lambdaScope lam of
                                Nothing -> sc
                                Just s -> modifyGlobalScope s (\sc' -> sc' { outerScope = Just sc })
                  throwReturn $ LitLambda lam { lambdaScope = Just newS }
              y -> throwReturn y


execBreak :: Maybe Expr -> ExecIO LangLit
execBreak x = case x of
                Nothing -> throwBreak Nothing
                Just v  -> execExpr v
                          >>= returnVal >>= (throwBreak . Just)


raiseException :: LangIdent -> ExecIO LangLit
raiseException e = do
  env <- getEnv
  let currE = currentException env
  return (LitKeyword e)
  case currE of
        Nothing -> throwExecError $ userErr e
        Just err -> if similarErr err
                   then throwAE err
                   else throwExecError $ userErr e
  where
    similarErr err = errToKeyword err == e
                   || genErrKeyword err == e
                   || LangIdent "error" == e


execLangStruct :: LangStruct -> ExecIO LangLit
execLangStruct (StructFor name e s)
    = execStructFor name e s `catchBreak` maybe (getEnvValue >>= returnVal) returnVal
execLangStruct (StructWhile e s)
    = execStructWhile e s `catchBreak` maybe (getEnvValue >>= returnVal) returnVal
execLangStruct (StructIf if' thn els)
    = execStructIf if' thn els
execLangStruct (StructDefun name cs)
    = assignVarFunLocal name cs *> return LitNull
execLangStruct (StructTryCatch b cs)
    = execStructTryCatch b cs


execStructIf :: Expr -> Stmt -> Maybe Stmt -> ExecIO LangLit
execStructIf if' thn els = do
  p <- execExpr if'
  case p of
    (LitBool True)  -> execStmt thn
    (LitBool False) -> case els of
                         Nothing -> return LitNull
                         Just s  -> execStmt s
    x               -> throwExecError $ typeUnexpectedErr (typeOf x) LTBool


execStructFor :: LangIdent -> Expr -> Stmt -> ExecIO LangLit
execStructFor name e s = do
  iterable <- execExpr e >>= fromIter
  outScope <- liftM currentScope getEnv
  res <- forM iterable (\v -> do
                   assignVarLitLocal name v
                   execStmt s `catchContinue` getEnvValue)
  newS <- liftM currentScope getEnv
  let newS' = deleteLitFromScope name newS
  modifyScope (const $ mergeScope newS' outScope)
  returnVal (LitList res)


execStructWhile :: Expr -> Stmt -> ExecIO LangLit
execStructWhile ex s = do
  pos <- liftM envSourceRef getEnv
  execStructFor (LangIdent "__WHILEVAL__")
                    (ExprLit
                     (LitRange (LitInt 1) Nothing Nothing))
                     (SingleStmt
                     (StmtStruct
                      (StructIf ex s (Just (SingleStmt (StmtBreak Nothing False) pos)))) pos)


execStructTryCatch :: Stmt -> [([LangIdent], Stmt)] -> ExecIO LangLit
execStructTryCatch b catchers = do
    currEnv <- getEnv
    execStmt b `catchAE` genHandle currEnv
  where
    genHandle env e = do
      cscope <- getScope -- Preserve the scope!
      updateEnv env { currentException = Just e, currentScope = cscope }
      res <- checkCatch e catchers `catchBreak` breakTry
      newEnv <- getEnv
      updateEnv newEnv { currentException = Nothing }
      return res
    checkCatch e [] = throwError e
    checkCatch e ((toCatch, ex):es) = if catches
                                      then execStmt ex
                                      else checkCatch e es
      where catches = errToKeyword e `elem` toCatch || genErrKeyword e `elem` toCatch
                    || LangIdent "error" `elem` toCatch
    breakTry (Just (LitKeyword (LangIdent "try")))
        = execStructTryCatch b catchers
    breakTry e = throwBreak e


builtinArgs :: [Expr] -> ExecIO [LangLit]
builtinArgs xs = expandParams xs >>= mapM execExpr


callBuiltin :: LangIdent -> [Expr] -> ExecIO LangLit
callBuiltin (LangIdent "print")    xs = builtinArgs xs >>= builtinPrint
callBuiltin (LangIdent "str")      xs = builtinArgs xs >>= builtinStr
callBuiltin (LangIdent "index")    xs = builtinArgs xs >>= builtinIndex
callBuiltin (LangIdent "length")   xs = builtinArgs xs >>= builtinLength
callBuiltin (LangIdent "input")    xs = builtinArgs xs >>= builtinInput
callBuiltin (LangIdent "eval")     xs = builtinArgs xs >>= builtinEval
callBuiltin (LangIdent "asType")   xs = builtinArgs xs >>= builtinAsType
callBuiltin (LangIdent "getArgs")  xs = builtinArgs xs >>= builtinGetArgs
callBuiltin (LangIdent "isNull")   xs = builtinArgs xs >>= builtinIsNull
callBuiltin (LangIdent "open")     xs = builtinArgs xs >>= builtinOpen
callBuiltin (LangIdent "read")     xs = builtinArgs xs >>= builtinRead
callBuiltin (LangIdent "write")    xs = builtinArgs xs >>= builtinWrite
callBuiltin (LangIdent "close")    xs = builtinArgs xs >>= builtinClose
callBuiltin (LangIdent "shell")    xs = builtinArgs xs >>= builtinShell
callBuiltin (LangIdent "include")  xs = builtinArgs xs >>= builtinInclude
callBuiltin (LangIdent "nonlocal") xs = builtinArgs xs >>= builtinNonLocal
callBuiltin (LangIdent "global")   xs = builtinArgs xs >>= builtinGlobal
callBuiltin (LangIdent "local")    xs = builtinArgs xs >>= builtinLocal
callBuiltin (LangIdent "round")    xs = builtinArgs xs >>= builtinRound
callBuiltin (LangIdent x) _ = throwImplementationErr $ "callBuiltin - not a builtin function: " ++ x


builtinEval :: [LangLit] -> ExecIO LangLit
builtinEval xs = do
  let r = evalParse st program
  case r of
    Left e    -> throwExecError . syntaxErr $ e
    Right res -> execStmt res
  where st = argsToString xs


-- | Builtin @include@ function.
--
-- @include(file_names)@ will attempt to open, read and evaluate
-- each file in @file_names@ inplace. This is effectively the
-- same as having written the code contained within the files
-- at the point of call.
--
-- If any of @file_names@ are handles, then they will be read
-- fully and evaluated.
--
-- Filepaths are assumed to be relative, unless an absolute
-- path is provided.
builtinInclude :: [LangLit] -> ExecIO LangLit
builtinInclude xs = mapM_ includeFile xs >> return LitNull
  where
    includeFile h@(LitHandle _) = builtinRead [h] >>= builtinEval . (:[])
    includeFile (LitStr f) = includeAngleFile f
    includeFile x = throwExecError $ typeNotValidErr x
    includeAngleFile f = do
        fn <- getAngleFile f
        case fn of
            Nothing -> throwExecError . noSuchFileErr $ f
            Just pth -> do
              txt <- builtinRead [LitStr pth]
              env <- getEnv
              currFile <- liftM currentFile getEnv
              currMain <- liftM runAsMain getEnv
              currScope <- liftM currentScope getEnv
              updateEnv env { currentFile = Just pth, runAsMain = False }
              builtinEval [txt]
                  `catchAE` (\e -> do
                      newEnv <- getEnv
                      updateEnv env
                      throwAE e)
              -- newEnv <- getEnv
              recentScope <- liftM currentScope getEnv
              updateEnv env { currentScope = mergeScope recentScope currScope }
              -- updateEnv newEnv { currentFile = currFile, runAsMain = currMain }
              return LitNull
-- builtinRead [f] >>= builtinEval . (:[])


-- | Builtin @nonlocal@ function.
--
-- @nonlocal(var)@ attempts to lookup the value of @var@ in any
-- of the parent scopes of the current scope. Fails with a
-- @nameError@ if @var@ is not defined.
--
-- @nonlocal(:fun, var)@ attempts to lookup the lambda value
-- of @var@ in a parent scope.
builtinNonLocal :: [LangLit] -> ExecIO LangLit
builtinNonLocal [LitKeyword (LangIdent "fun"), LitKeyword n]
    = liftM LitLambda $ lookupVarFunOuter n
builtinNonLocal [LitKeyword n]
    = lookupVarLitOuter n
builtinNonLocal _ = throwExecError . callBuiltinErr $ "nonlocal: invalid call signature"


-- | Builtin @global@ function.
--
-- @global(var)@ attempts to lookup the value of @var@ in the global
-- scope. Fails with a @nameError@ if @var@ is not defined.
--
-- @global(:fun, var)@ attempts to lookup the lambda value
-- of @var@ in the global scope.
builtinGlobal :: [LangLit] -> ExecIO LangLit
builtinGlobal [LitKeyword (LangIdent "fun"), LitKeyword n]
    = liftM LitLambda $ lookupVarFunGlobal n
builtinGlobal [LitKeyword n]
    = lookupVarLitGlobal n
builtinGlobal _ = throwExecError . callBuiltinErr $ "global: invalid call signature"


-- | Built-in @local@ function.
--
-- @local(var)@ attempts to resolve the variable represented by the keyword
-- @var@.
--
-- @local(:fun, var)@ attempts to resove the lambda value of @var@@
builtinLocal :: [LangLit] -> ExecIO LangLit
builtinLocal [LitKeyword (LangIdent "fun"), LitKeyword n]
    = liftM LitLambda $ lookupVarFunLocal n
builtinLocal [LitKeyword n]
    = lookupVarLitLocal n
builtinLocal _ = throwExecError . callBuiltinErr $ "local: invalid call signature"


getAngleFile :: FilePath -> ExecIO (Maybe FilePath)
getAngleFile fp = do
    searchPath <- liftM angleLibPath getEnv
    currFile <- liftM currentFile getEnv
    maybeFound <- liftIO $ findFile (searchPath ++ [maybe "" takeDirectory currFile, ""]) fp
    case maybeFound of
        Nothing -> return Nothing
        Just p -> liftM Just $ liftIO $ canonicalizePath p


validRangeLit :: LangLit -> Bool
validRangeLit (LitRange x Nothing Nothing)
    = enumType x
validRangeLit (LitRange x (Just y) Nothing)
    = enumType x && typeOf x == typeOf y
validRangeLit (LitRange x (Just y) (Just z))
    = enumType x && all ((== typeOf x) . typeOf) [y, z]
validRangeLit (LitRange x Nothing (Just z))
    = enumType x && typeOf x == typeOf z
validRangeLit _ = error "validRangeLit: Attempting to verify a non-range"


checkLitRange :: LangLit -> ExecIO ()
checkLitRange r@(LitRange x y z)
    = unless (validRangeLit r)
      (if enumType x
       then throwExecError $ badRangeErr (typeOf x) (fmap typeOf y) (fmap typeOf z)
       else throwExecError $ typeExpectConstrErr x (LangIdent "enum"))
checkLitRange _ = throwImplementationErr "checkLitRange: Attempting to check a non-range"