/src/Hummus/Prelude.hs

  1{-# LANGUAGE RankNTypes #-}
  2module Hummus.Prelude where
  3
  4import Control.Monad
  5import Control.Monad.CC
  6import Control.Monad.CC.Dynvar
  7import Control.Monad.Trans
  8import Data.Attoparsec
  9import Data.IORef
 10import Data.Time
 11import qualified Data.ByteString as BS
 12
 13import Hummus.Types
 14import Hummus.Parser
 15import Hummus.Runtime
 16
 17import Paths_hummus
 18
 19
 20new :: VM ans (Value ans)
 21new = do
 22  env <- newEnvironment []
 23
 24  defn env "make-encapsulation-type" $ \Null _ -> do
 25    i <- liftIO (newIORef ())
 26
 27    let cons =
 28          Applicative . CoreOperative $ \(Pair a Null) _ -> do
 29            vr <- liftIO (newIORef a)
 30            return Encapsulation { eID = i, eValue = vr }
 31
 32        test =
 33          Applicative . CoreOperative $ \(Pair a Null) _ ->
 34            case a of
 35              Encapsulation { eID = eid } -> return (Boolean (eid == i))
 36              _ -> return (Boolean False)
 37
 38        decons =
 39          Applicative . CoreOperative $ \(Pair a Null) _ ->
 40            case a of
 41              Encapsulation { eID = eid, eValue = vr } | eid == i ->
 42                liftIO (readIORef vr)
 43
 44              _ -> error "encapsulation type mismatch"
 45
 46    return (Pair cons (Pair test (Pair decons Null)))
 47
 48  defn env "reset" $ \(Pair b _) e ->
 49    reset $ \p ->
 50      apply e b (Pair (Prompt p) Null)
 51
 52  defn env "make-dynvar" $ \(Pair a _) _ ->
 53    liftM (flip Dynvar a) dnew
 54
 55  defn env "put!" $ \(Pair (Dynvar d _) (Pair b Null)) _ ->
 56    dset d b
 57
 58  def env "with" $ \(Pair as bs) e -> do
 59    letDyn e (map toList (toList as)) (toList bs)
 60
 61  defn env "shift" $ \(Pair a (Pair b _)) e -> do
 62    Prompt p <- evaluate e a
 63    shift p $ \f ->
 64      let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x)
 65      in apply e b (Pair app Null)
 66
 67  defn env "control" $ \(Pair a (Pair b _)) e -> do
 68    Prompt p <- evaluate e a
 69    control p $ \f ->
 70      let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x)
 71      in apply e b (Pair app Null)
 72
 73  defn env "shift0" $ \(Pair a (Pair b _)) e -> do
 74    Prompt p <- evaluate e a
 75    shift0 p $ \f ->
 76      let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x)
 77      in apply e b (Pair app Null)
 78
 79  defn env "control0" $ \(Pair a (Pair b _)) e -> do
 80    Prompt p <- evaluate e a
 81    control0 p $ \f ->
 82      let app = Applicative . CoreOperative $ \(Pair x _) _ -> f (return x)
 83      in apply e b (Pair app Null)
 84
 85  def env "abort" $ \(Pair a (Pair b _)) e -> do
 86    Prompt p <- evaluate e a
 87    abort p (evaluate e b)
 88
 89  defn env "boolean?"  $ \(Pair a _) _ ->
 90    return (Boolean (isBoolean a))
 91
 92  defn env "eq?"  $ \(Pair a (Pair b _)) _ ->
 93    return (Boolean (a == b))
 94
 95  evaluate env (Symbol "eq?") >>= define env (Symbol "equal?")
 96
 97  defn env "symbol?"  $ \(Pair a _) _ ->
 98    return (Boolean (isSymbol a))
 99
100  defn env "string?"  $ \(Pair a _) _ ->
101    return (Boolean (isString a))
102
103  defn env "subcontinuation?"  $ \(Pair a _) _ ->
104    return (Boolean (isSubContinuation a))
105
106  defn env "prompt?"  $ \(Pair a _) _ ->
107    return (Boolean (isPrompt a))
108
109  defn env "inert?"  $ \(Pair a _) _ ->
110    return (Boolean (isInert a))
111
112  defn env "pair?"  $ \(Pair a _) _ ->
113    return (Boolean (isPair a))
114
115  defn env "null?"  $ \(Pair a _) _ ->
116    return (Boolean (isNull a))
117
118  defn env "cons"  $ \(Pair a (Pair b _)) _ ->
119    return (Pair a b)
120
121  def env "if" $ \(Pair a (Pair b (Pair c _))) e -> do
122    t <- evaluate e a
123
124    case t of
125      Boolean True ->
126        evaluate e b
127
128      Boolean False ->
129        evaluate e c
130
131      _ -> error ("not a boolean: " ++ show t)
132
133  defn env "environment?"  $ \(Pair a _) _ ->
134    return (Boolean (isEnvironment a))
135
136  defn env "ignore?"  $ \(Pair a _) _ ->
137    return (Boolean (isIgnore a))
138
139  defn env "number?"  $ \(Pair a _) _ ->
140    return (Boolean (isNumber a))
141
142  defn env "eval"  $ \(Pair a (Pair b _)) _ ->
143    evaluate b a
144
145  defn env "make-environment" $ \parents _ ->
146    newEnvironment (toList parents)
147
148  def env "binds?" $ \(Pair a bs) e -> do
149    e' <- evaluate e a
150    ss <- mapM (\(Symbol s) -> binds e' s) (toList bs)
151    return (Boolean (and ss))
152
153  def env "define" $ \(Pair a (Pair b _)) e -> do
154    v <- evaluate e b
155    define e a v
156    return Inert
157
158  defn env "operative?" $ \(Pair a _) _ ->
159    return (Boolean (isOperative a))
160
161  defn env "applicative?" $ \(Pair a _) _ ->
162    return (Boolean (isApplicative a))
163
164  defn env "dynvar?" $ \(Pair a _) _ ->
165    return (Boolean (isDynvar a))
166
167  defn env "combiner?" $ \as _ ->
168    return (Boolean (and (map isCombiner (toList as))))
169
170  def env "vau" $ \(Pair a (Pair b (Pair c _))) e ->
171    return (Operative a b c (Just e))
172
173  defn env "wrap"  $ \(Pair a _) _ ->
174    return (Applicative a)
175
176  defn env "unwrap"  $ \(Pair a _) _ ->
177    case a of
178      Applicative c -> return c
179      _ -> error ("not an applicative: " ++ show a)
180
181  defn env "make-prompt" $ \Null _ -> do
182    x <- newPrompt
183    return (Prompt x)
184
185  def env "push-prompt" $ \(Pair a bs) e -> do
186    Prompt p <- evaluate e a
187    pushPrompt p (evaluateSequence e (toList bs))
188
189  defn env "with-sub-cont" $ \(Pair (Prompt p) (Pair x Null)) e -> do
190    withSubCont p $ \s ->
191      apply e x (Pair (SubContinuation s) Null)
192
193  defn env "push-sub-cont" $ \(Pair a bs) e -> do
194    SubContinuation s <- evaluate e a
195    pushSubCont s (evaluateSequence e (toList bs))
196
197  defn env "=?"  $ \as _ ->
198    let allEq (a:b:cs) = a == b && allEq (b:cs)
199        allEq _ = True
200    in return (Boolean (allEq (toList as)))
201
202  defn env "max"  $ \as _ ->
203    let nums = map (\(Number n) -> n) (toList as)
204    in return (Number (maximum nums))
205
206  defn env "<?"  $ \(Pair (Number a) (Pair (Number b) _)) _ ->
207    return (Boolean (a < b))
208
209  defn env ">?"  $ \(Pair (Number a) (Pair (Number b) _)) _ ->
210    return (Boolean (a > b))
211
212  defn env "<=?"  $ \(Pair (Number a) (Pair (Number b) _)) _ ->
213    return (Boolean (a <= b))
214
215  defn env ">=?"  $ \(Pair (Number a) (Pair (Number b) _)) _ ->
216    return (Boolean (a >= b))
217
218  defn env "+"  $ \as _ ->
219    let nums = map (\(Number n) -> n) (toList as)
220    in return (Number (sum nums))
221
222  defn env "*"  $ \as _ ->
223    let nums = map (\(Number n) -> n) (toList as)
224    in return (Number (product nums))
225
226  defn env "-"  $ \(Pair (Number a) (Pair (Number b) _)) _ ->
227    return (Number (a - b))
228
229  defn env "print" $ \(Pair a _) _ -> do
230    case a of
231      String s -> liftIO (putStrLn s)
232      _ -> liftIO (print a)
233
234    return Inert
235
236  defn env "display" $ \(Pair a _) _ -> do
237    case a of
238      String s -> liftIO (putStr s)
239      _ -> liftIO (putStr (show a))
240
241    return Inert
242
243  defn env "write" $ \(Pair a _) _ -> do
244    liftIO (print a)
245    return Inert
246
247  defn env "show" $ \(Pair a _) _ ->
248    return (String (show a))
249
250  def env "time" $ \(Pair a _) e -> do
251    before <- liftIO getCurrentTime
252    x <- evaluate e a
253    after <- liftIO getCurrentTime
254    liftIO (print x)
255    liftIO (print (diffUTCTime after before))
256    return Inert
257
258  def env "loop" $ \as e ->
259    forever $ evaluateSequence e (toList as)
260
261  defn env "get-hummus-data-file" $ \(Pair (String fn) _) _ -> do
262    liftM String (liftIO (getDataFileName fn))
263
264  defn env "load" $ \(Pair (String fn) _) e -> do
265    source <- liftIO (BS.readFile fn)
266    case parseOnly sexps source of
267      Right ss ->
268        evaluateSequence e ss
269
270      Left msg ->
271        error msg
272
273  defn env "string->symbol" $ \(Pair (String s) _) _ ->
274    return (Symbol s)
275
276  defn env "symbol->string" $ \(Pair (Symbol s) _) _ ->
277    return (String s)
278
279  defn env "join" $ \as _ ->
280    return (String (concatMap (\(String s) -> s) (toList as)))
281
282  bootFile <- liftIO (getDataFileName "kernel/boot.hms")
283  boot <- liftIO (BS.readFile bootFile)
284  case parseOnly sexps boot of
285    Right ss ->
286      mapM_ (evaluate env) ss
287
288    Left e ->
289      error e
290
291  return env
292 where
293  def :: Value ans -> String -> (Value ans -> Value ans -> VM ans (Value ans)) -> VM ans ()
294  def e n f = define e (Symbol n) (CoreOperative f)
295
296  defn :: Value ans -> String -> (Value ans -> Value ans -> VM ans (Value ans)) -> VM ans ()
297  defn e n f = define e (Symbol n) (Applicative $ CoreOperative f)
298
299  letDyn :: Value ans -> [[Value ans]] -> [Value ans] -> VM ans (Value ans)
300  letDyn e [] bs = evaluateSequence e bs
301  letDyn e ([a, b]:as) bs = do
302    Dynvar d _ <- evaluate e a
303    v <- evaluate e b
304    dlet d v (letDyn e as bs)
305  letDyn _ (p:_) _ = error $ "unknown pair: " ++ show p
306
307fromGround :: (Value ans -> VM ans (Value ans)) -> VM ans (Value ans)
308fromGround x = do
309  e <- new
310
311  reset $ \root -> do
312    define e (Symbol "root-prompt") (Prompt root)
313    x e