haskell/Types.hs

   1 module Types
   2 (MalVal (..), MalError (..), IOThrows (..), Fn (..), EnvData (..), Env,
   3  throwStr, throwMalVal, _get_call, _to_list,
   4  _func, _malfunc,
   5  _nil_Q, _true_Q, _false_Q, _string_Q, _symbol_Q, _keyword_Q,
   6  _list_Q, _vector_Q, _hash_map_Q, _atom_Q)
   7 where
   8
   9 import Data.IORef (IORef)
  10 import qualified Data.Map as Map
  11 import Control.Exception as CE
  12 import Control.Monad.Error (ErrorT, Error, noMsg, strMsg, throwError)
  13
  14
  15 -- Base Mal types --
  16 newtype Fn = Fn ([MalVal] -> IOThrows MalVal)
  17 data MalVal = Nil
  18             | MalFalse
  19             | MalTrue
  20             | MalNumber   Int
  21             | MalString   String
  22             | MalSymbol   String
  23             | MalList     [MalVal] MalVal
  24             | MalVector   [MalVal] MalVal
  25             | MalHashMap  (Map.Map String MalVal) MalVal
  26             | MalAtom     (IORef MalVal) MalVal
  27             | Func        Fn MalVal
  28             | MalFunc     {fn :: Fn,
  29                            ast :: MalVal,
  30                            env :: Env,
  31                            params :: MalVal,
  32                            macro :: Bool,
  33                            meta :: MalVal}
  34
  35 _equal_Q Nil Nil = True
  36 _equal_Q MalFalse MalFalse = True
  37 _equal_Q MalTrue MalTrue = True
  38 _equal_Q (MalNumber a) (MalNumber b) = a == b
  39 _equal_Q (MalString a) (MalString b) = a == b
  40 _equal_Q (MalSymbol a) (MalSymbol b) = a == b
  41 _equal_Q (MalList a _) (MalList b _) = a == b
  42 _equal_Q (MalList a _) (MalVector b _) = a == b
  43 _equal_Q (MalVector a _) (MalList b _) = a == b
  44 _equal_Q (MalVector a _) (MalVector b _) = a == b
  45 _equal_Q (MalHashMap a _) (MalHashMap b _) = a == b
  46 _equal_Q (MalAtom a _) (MalAtom b _) = a == b
  47 _equal_Q _ _ = False
  48
  49 instance Eq MalVal where
  50     x == y = _equal_Q x y
  51
  52
  53 --- Errors/Exceptions ---
  54
  55 data MalError = StringError String
  56               | MalValError MalVal
  57
  58 type IOThrows = ErrorT MalError IO
  59
  60 instance Error MalError where
  61     noMsg = StringError "An error has occurred"
  62     strMsg = StringError
  63
  64 throwStr str = throwError $ StringError str
  65 throwMalVal mv = throwError $ MalValError mv
  66
  67 -- Env types --
  68 -- Note: Env functions are in Env module
  69 data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal))
  70 type Env = IORef EnvData
  71
  72
  73
  74 ----------------------------------------------------------
  75
  76 -- General functions --
  77
  78 _get_call ((Func (Fn f) _) : _) = return f
  79 _get_call (MalFunc {fn=(Fn f)} : _) = return f
  80 _get_call _ = throwStr "_get_call first parameter is not a function "
  81
  82 _to_list (MalList lst _) = return lst
  83 _to_list (MalVector lst _) = return lst
  84 _to_list _ = throwStr "_to_list expected a MalList or MalVector"
  85
  86 -- Errors
  87
  88 --catchAny :: IO a -> (CE.SomeException -> IO a) -> IO a
  89 --catchAny = CE.catch
  90
  91 -- Functions
  92
  93 _func fn = Func (Fn fn) Nil
  94 _func_meta fn meta = Func (Fn fn) meta
  95
  96 _malfunc ast env params fn = MalFunc {fn=(Fn fn), ast=ast,
  97                                       env=env, params=params,
  98                                       macro=False, meta=Nil}
  99 _malfunc_meta ast env params fn meta = MalFunc {fn=(Fn fn), ast=ast,
 100                                                 env=env, params=params,
 101                                                 macro=False, meta=meta}
 102
 103 -- Scalars
 104 _nil_Q Nil = MalTrue
 105 _nil_Q _   = MalFalse
 106
 107 _true_Q MalTrue = MalTrue
 108 _true_Q _       = MalFalse
 109
 110 _false_Q MalFalse = MalTrue
 111 _false_Q _        = MalFalse
 112
 113 _symbol_Q (MalSymbol _) = MalTrue
 114 _symbol_Q _             = MalFalse
 115
 116 _string_Q (MalString ('\x029e':_)) = MalFalse
 117 _string_Q (MalString _)            = MalTrue
 118 _string_Q _                        = MalFalse
 119
 120 _keyword_Q (MalString ('\x029e':_)) = MalTrue
 121 _keyword_Q _                        = MalFalse
 122
 123 -- Lists
 124
 125 _list_Q (MalList _ _) = MalTrue
 126 _list_Q _             = MalFalse
 127
 128 -- Vectors
 129
 130 _vector_Q (MalVector _ _) = MalTrue
 131 _vector_Q _               = MalFalse
 132
 133 -- Hash Maps
 134
 135 _hash_map_Q (MalHashMap _ _) = MalTrue
 136 _hash_map_Q _                = MalFalse
 137
 138 -- Atoms
 139
 140 _atom_Q (MalAtom _ _) = MalTrue
 141 _atom_Q _             = MalFalse