Internal.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-|
Module      : Angle.Exec.Types.Internal
Description : Defines types used for executing Angle programs.
Copyright   : Copyright (C) 2015 Ben Moon
License     : GNU GPL, version 3
Maintainer  : GuiltyDolphin@gmail.com
Stability   : alpha

Defines the base types (ExecIO and Env) for executing Angle programs.

Also defines functions for working with iterable types in Angle.
-}
module Angle.Exec.Types.Internal
    ( ExecIO
    , runExecIOBasic
    , runExecIOEnv
    , fromIter
    , returnVal
    , iterToLit
    , fromEnumL
    , isInfiniteRange
    -- ** Excution environment
    , Env(..)
    , getEnv
    , updateEnv
    , basicEnv
    , getEnvValue
    , setEnvSynRep
    , updatePos

    , pushEnvCall
    , popEnvCall

    , updateStmt
    ) where


import Control.Applicative
import Control.Monad.Except
import Control.Monad.Trans.Except
import Control.Monad.State

import Angle.Exec.Error
import Angle.Types.Lang
import Angle.Types.Scope


-- | Angle program execution monad.
newtype ExecIO a = ExecIO
    { runExecIO :: ExceptT AngleError (StateT Env IO) a }
    deriving ( Functor, Applicative, Monad
             , MonadIO)


instance MonadError AngleError ExecIO where
    throwError = throwAE
    catchError = catchAE


instance CanErrorWithPos ExecIO where
    getErrorPos = liftM envSourceRef get
    getErrorSource = liftM sourceText get
    getErrorFile = liftM currentFile get
    getErrorCallStack = liftM (currentStack . callStack) get
    getErrorCall = liftM (((,) <$> currentName <*>  currentStmt) . callStack) get


instance CanError ExecIO where
    throwAE = ExecIO . throwE
    catchAE (ExecIO e) h
        = ExecIO (lift $ runExceptT e) >>= either h return


instance MonadState Env ExecIO where
    get = ExecIO $ lift get
    put x = ExecIO $ lift $ put x


-- | Environment in which Angle programs execute.
data Env = Env { currentScope :: Scope
               , sourceText :: String
               , envSourceRef :: SourceRef
               , envSynRep :: String
               , envValue :: LangLit
               , currentException :: Maybe AngleError
               , callStack :: CallStack
               -- ^ Calls and the statements that call them.
               , angleLibPath :: [FilePath]
               , currentFile :: Maybe FilePath
               , runAsMain :: Bool
               } deriving (Show, Eq)


-- | Track function calls and statement execution.
data CallStack = CallStack
    { currentStack :: [(LangIdent, Stmt)]
    , currentName :: LangIdent
    , currentStmt :: Stmt
    } deriving (Show, Eq)


startStack :: CallStack
startStack = CallStack { currentStack = []
                       , currentName = LangIdent "MODULE" }

-- | Retrieve the current execution environment.
getEnv :: ExecIO Env
getEnv = get


-- | Update the current execution environment
updateEnv :: Env -> ExecIO ()
updateEnv = put


-- | Run Angle program with a custom environment.
runExecIOEnv :: Env -> ExecIO a -> IO (Either AngleError a)
runExecIOEnv e x = evalStateT (runExceptT $ runExecIO x) e


-- | Run Angle program with a basic environment.
runExecIOBasic :: ExecIO a -> IO (Either AngleError a)
runExecIOBasic = runExecIOEnv basicEnv


-- | Update the current environment tracking position.
updatePos :: SourceRef -> ExecIO ()
updatePos pos = modify (\e -> e { envSourceRef = pos })


-- | Set the environment's current syntax representation.
setEnvSynRep :: String -> ExecIO ()
setEnvSynRep x = modify (\e -> e { envSynRep = x })


-- | Basic environment.
basicEnv :: Env
basicEnv = Env { currentScope = emptyScope
               , sourceText = ""
               , envSourceRef = startRef
               , envSynRep = ""
               , envValue = LitNull
               , currentException = Nothing
               , angleLibPath = []
               , currentFile = Nothing
               , callStack = startStack
               }


-- In a language like Java, could use try..catch
-- to exit early from function, maybe something
-- similar for this?

-- For this,
-- Throw the 'error' in the return statement,
-- then catch it in the calling expression.

-- | Set the current value in the execution environment.
returnVal :: LangLit -> ExecIO LangLit
returnVal v = putEnvValue v >> return v


-- | Retrieve the current environment value.
getEnvValue :: ExecIO LangLit
getEnvValue = liftM envValue get


putEnvValue :: LangLit -> ExecIO ()
putEnvValue v = modify (\e -> e {envValue=v})


popEnvCall :: ExecIO ()
popEnvCall = do
    currEnv <- getEnv
    let currStack = callStack currEnv
        ((newName,_):newStack) = currentStack currStack
        newCallStack = currStack { currentStack = newStack, currentName = newName }
    put currEnv { callStack = newCallStack }


pushEnvCall :: LangIdent -> ExecIO ()
pushEnvCall newCall = do
    currEnv <- getEnv
    let currStack = callStack currEnv
        oldName = currentName currStack
        oldStmt = currentStmt currStack
        oldStack = currentStack currStack
        newStack = (oldName, oldStmt) : oldStack
        newCallStack = currStack { currentName = newCall, currentStack = newStack }
    put currEnv { callStack = newCallStack }


updateStmt :: Stmt -> ExecIO ()
updateStmt s = do
    currEnv <- getEnv
    let oldStack = callStack currEnv
    put currEnv { callStack = oldStack { currentStmt = s } }


-- | Convert a list or range into a list of literals.
fromIter :: LangLit -> ExecIO [LangLit]
fromIter (LitList xs) = return xs
fromIter (LitStr xs) = return $ map LitChar xs
fromIter (LitRange x (Just y) Nothing) = iterFromTo x y
fromIter (LitRange x (Just y) (Just z)) = iterFromThenTo x y z
fromIter (LitRange x Nothing Nothing) = iterFrom x
fromIter (LitRange x Nothing (Just y)) = iterFromThen x y
fromIter x = throwExecError $ nonEnumErr $ typeOf x


-- | True if the range has infinite size.
isInfiniteRange :: LangLit -> Bool
isInfiniteRange (LitRange _ Nothing _) = True
isInfiniteRange (LitRange x (Just y) (Just z))
       = (y' > x' || y' == x') && zeroStep
  where
    [x',y',z'] = map fromEnumL [x,y,z]
    zeroStep = z' == x'
isInfiniteRange (LitRange x y@(Just _) Nothing) = isInfiniteRange (LitRange x y (Just (LitInt (fromEnumL x + 1))))
isInfiniteRange _ = error "isInfiniteRange: Passed a non-range"


-- | Retrieve enum value from literal, literal must be
-- enumerable.
fromEnumL :: LangLit -> Int
fromEnumL (LitInt x) = fromEnum x
fromEnumL (LitChar x) = fromEnum x
fromEnumL (LitFloat x) = fromEnum x
fromEnumL _ = error "fromEnumL: non-enumerable type"


-- | Convert a list or range into a literal list.
iterToLit :: LangLit -> ExecIO LangLit
iterToLit x@(LitRange{}) | isInfiniteRange x = throwExecError infiniteRangeErr
iterToLit x = liftM LitList $ fromIter x


iterFromThenTo :: LangLit -> LangLit -> LangLit -> ExecIO [LangLit]
iterFromThenTo (LitInt x) (LitInt y) (LitInt z) = return $ map LitInt $ enumFromThenTo x z y -- (succ z) y
iterFromThenTo (LitFloat x) (LitFloat y) (LitFloat z) = return $ map LitFloat $ enumFromThenTo x z y -- (succ z) y
iterFromThenTo (LitChar x) (LitChar y) (LitChar z) = return $ map LitChar $ enumFromThenTo x z y -- (succ z) y
iterFromThenTo _ _ _ = throwImplementationErr "iterFromThenTo: cannot handle non-enumerable types"


-- Potential: looping to infinity (and beyond)
iterFrom :: LangLit -> ExecIO [LangLit]
iterFrom (LitInt x) = return $ map LitInt $ enumFrom x
iterFrom (LitChar x) = return $ map LitChar $ enumFrom x
iterFrom (LitFloat x) = return $ map LitFloat $ enumFrom x
iterFrom _ = throwImplementationErr "iterFrom: define failure"


iterFromThen :: LangLit -> LangLit -> ExecIO [LangLit]
iterFromThen (LitInt x) (LitInt y) = return $ map LitInt $ enumFromThen x y
iterFromThen (LitChar x) (LitChar y) = return $ map LitChar $ enumFromThen x y
iterFromThen (LitFloat x) (LitFloat y) = return $ map LitFloat $ enumFromThen x y
iterFromThen _ _ = throwImplementationErr "iterFromThen: define failure"



iterFromTo :: LangLit -> LangLit -> ExecIO [LangLit]
iterFromTo (LitInt x) (LitInt y) = return $ map LitInt $ enumFromTo x y
iterFromTo (LitChar x) (LitChar y) = return $ map LitChar $ enumFromTo x y
iterFromTo (LitFloat x) (LitFloat y) = return $ map LitFloat $ enumFromTo x y
iterFromTo _ _ = throwImplementationErr "iterFromTo: cannot handle non-enumerable types"