mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 10:07:45 +03:00
137 lines
3.7 KiB
Haskell
137 lines
3.7 KiB
Haskell
module Types
|
|
(MalVal (..), MalError (..), IOThrows (..), Fn (..), EnvData (..), Env,
|
|
throwStr, throwMalVal, _get_call, _to_list,
|
|
_func, _malfunc,
|
|
_nil_Q, _true_Q, _false_Q, _symbol_Q, _keyword_Q,
|
|
_list_Q, _vector_Q, _hash_map_Q, _atom_Q)
|
|
where
|
|
|
|
import Data.IORef (IORef)
|
|
import qualified Data.Map as Map
|
|
import Control.Exception as CE
|
|
import Control.Monad.Error (ErrorT, Error, noMsg, strMsg, throwError)
|
|
|
|
|
|
-- Base Mal types --
|
|
newtype Fn = Fn ([MalVal] -> IOThrows MalVal)
|
|
data MalVal = Nil
|
|
| MalFalse
|
|
| MalTrue
|
|
| MalNumber Int
|
|
| MalString String
|
|
| MalSymbol String
|
|
| MalList [MalVal] MalVal
|
|
| MalVector [MalVal] MalVal
|
|
| MalHashMap (Map.Map String MalVal) MalVal
|
|
| MalAtom (IORef MalVal) MalVal
|
|
| Func Fn MalVal
|
|
| MalFunc {fn :: Fn,
|
|
ast :: MalVal,
|
|
env :: Env,
|
|
params :: MalVal,
|
|
macro :: Bool,
|
|
meta :: MalVal}
|
|
|
|
_equal_Q Nil Nil = True
|
|
_equal_Q MalFalse MalFalse = True
|
|
_equal_Q MalTrue MalTrue = True
|
|
_equal_Q (MalNumber a) (MalNumber b) = a == b
|
|
_equal_Q (MalString a) (MalString b) = a == b
|
|
_equal_Q (MalSymbol a) (MalSymbol b) = a == b
|
|
_equal_Q (MalList a _) (MalList b _) = a == b
|
|
_equal_Q (MalList a _) (MalVector b _) = a == b
|
|
_equal_Q (MalVector a _) (MalList b _) = a == b
|
|
_equal_Q (MalHashMap a _) (MalHashMap b _) = a == b
|
|
_equal_Q (MalAtom a _) (MalAtom b _) = a == b
|
|
_equal_Q _ _ = False
|
|
|
|
instance Eq MalVal where
|
|
x == y = _equal_Q x y
|
|
|
|
|
|
--- Errors/Exceptions ---
|
|
|
|
data MalError = StringError String
|
|
| MalValError MalVal
|
|
|
|
type IOThrows = ErrorT MalError IO
|
|
|
|
instance Error MalError where
|
|
noMsg = StringError "An error has occurred"
|
|
strMsg = StringError
|
|
|
|
throwStr str = throwError $ StringError str
|
|
throwMalVal mv = throwError $ MalValError mv
|
|
|
|
-- Env types --
|
|
-- Note: Env functions are in Env module
|
|
data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal))
|
|
type Env = IORef EnvData
|
|
|
|
|
|
|
|
----------------------------------------------------------
|
|
|
|
-- General functions --
|
|
|
|
_get_call ((Func (Fn f) _) : _) = return f
|
|
_get_call (MalFunc {fn=(Fn f)} : _) = return f
|
|
_get_call _ = throwStr "_get_call first parameter is not a function "
|
|
|
|
_to_list (MalList lst _) = return lst
|
|
_to_list (MalVector lst _) = return lst
|
|
_to_list _ = throwStr "_to_list expected a MalList or MalVector"
|
|
|
|
-- Errors
|
|
|
|
--catchAny :: IO a -> (CE.SomeException -> IO a) -> IO a
|
|
--catchAny = CE.catch
|
|
|
|
-- Functions
|
|
|
|
_func fn = Func (Fn fn) Nil
|
|
_func_meta fn meta = Func (Fn fn) meta
|
|
|
|
_malfunc ast env params fn = MalFunc {fn=(Fn fn), ast=ast,
|
|
env=env, params=params,
|
|
macro=False, meta=Nil}
|
|
_malfunc_meta ast env params fn meta = MalFunc {fn=(Fn fn), ast=ast,
|
|
env=env, params=params,
|
|
macro=False, meta=meta}
|
|
|
|
-- Scalars
|
|
_nil_Q Nil = MalTrue
|
|
_nil_Q _ = MalFalse
|
|
|
|
_true_Q MalTrue = MalTrue
|
|
_true_Q _ = MalFalse
|
|
|
|
_false_Q MalFalse = MalTrue
|
|
_false_Q _ = MalFalse
|
|
|
|
_symbol_Q (MalSymbol _) = MalTrue
|
|
_symbol_Q _ = MalFalse
|
|
|
|
_keyword_Q (MalString ('\x029e':_)) = MalTrue
|
|
_keyword_Q _ = MalFalse
|
|
|
|
-- Lists
|
|
|
|
_list_Q (MalList _ _) = MalTrue
|
|
_list_Q _ = MalFalse
|
|
|
|
-- Vectors
|
|
|
|
_vector_Q (MalVector _ _) = MalTrue
|
|
_vector_Q _ = MalFalse
|
|
|
|
-- Hash Maps
|
|
|
|
_hash_map_Q (MalHashMap _ _) = MalTrue
|
|
_hash_map_Q _ = MalFalse
|
|
|
|
-- Atoms
|
|
|
|
_atom_Q (MalAtom _ _) = MalTrue
|
|
_atom_Q _ = MalFalse
|