
   0 | module Libraries.Utils.Scheme
   1 | 
   2 | export
   3 | data ForeignObj : Type where [external]
   4 | 
   5 | %foreign "scheme:blodwen-eval-scheme"
   6 | prim__evalScheme : String -> ForeignObj
   7 | 
   8 | %foreign "scheme:blodwen-eval-okay"
   9 | prim__evalOkay : ForeignObj -> Int
  10 | 
  11 | %foreign "scheme:blodwen-get-eval-result"
  12 | prim__evalResult : ForeignObj -> ForeignObj
  13 | 
  14 | %foreign "scheme:blodwen-debug-scheme"
  15 | prim__debugScheme : ForeignObj -> PrimIO ()
  16 | 
  17 | %foreign "scheme:blodwen-is-number"
  18 | prim_isNumber : ForeignObj -> Int
  19 | 
  20 | %foreign "scheme:blodwen-is-integer"
  21 | prim_isInteger : ForeignObj -> Int
  22 | 
  23 | %foreign "scheme:blodwen-is-float"
  24 | prim_isFloat : ForeignObj -> Int
  25 | 
  26 | %foreign "scheme:blodwen-is-char"
  27 | prim_isChar : ForeignObj -> Int
  28 | 
  29 | %foreign "scheme:blodwen-is-string"
  30 | prim_isString : ForeignObj -> Int
  31 | 
  32 | %foreign "scheme:blodwen-is-procedure"
  33 | prim_isProcedure : ForeignObj -> Int
  34 | 
  35 | %foreign "scheme:blodwen-is-symbol"
  36 | prim_isSymbol : ForeignObj -> Int
  37 | 
  38 | %foreign "scheme:blodwen-is-nil"
  39 | prim_isNil : ForeignObj -> Int
  40 | 
  41 | %foreign "scheme:blodwen-is-pair"
  42 | prim_isPair : ForeignObj -> Int
  43 | 
  44 | %foreign "scheme:blodwen-is-vector"
  45 | prim_isVector : ForeignObj -> Int
  46 | 
  47 | %foreign "scheme:blodwen-is-box"
  48 | prim_isBox : ForeignObj -> Int
  49 | 
  50 | export
  51 | isNumber : ForeignObj -> Bool
  52 | isNumber x = prim_isNumber x == 1
  53 | 
  54 | export
  55 | isInteger : ForeignObj -> Bool
  56 | isInteger x = prim_isInteger x == 1
  57 | 
  58 | export
  59 | isFloat : ForeignObj -> Bool
  60 | isFloat x = prim_isFloat x == 1
  61 | 
  62 | export
  63 | isChar : ForeignObj -> Bool
  64 | isChar x = prim_isChar x == 1
  65 | 
  66 | export
  67 | isString : ForeignObj -> Bool
  68 | isString x = prim_isString x == 1
  69 | 
  70 | export
  71 | isProcedure : ForeignObj -> Bool
  72 | isProcedure x = prim_isProcedure x == 1
  73 | 
  74 | export
  75 | isSymbol : ForeignObj -> Bool
  76 | isSymbol x = prim_isSymbol x == 1
  77 | 
  78 | export
  79 | isNil : ForeignObj -> Bool
  80 | isNil x = prim_isNil x == 1
  81 | 
  82 | export
  83 | isPair : ForeignObj -> Bool
  84 | isPair x = prim_isPair x == 1
  85 | 
  86 | export
  87 | isVector : ForeignObj -> Bool
  88 | isVector x = prim_isVector x == 1
  89 | 
  90 | export
  91 | isBox : ForeignObj -> Bool
  92 | isBox x = prim_isBox x == 1
  93 | 
  94 | -- The below are all 'unsafe' because they rely on having done the relevant
  95 | -- check above first
  96 | %foreign "scheme:blodwen-id"
  97 | export
  98 | unsafeGetInteger : ForeignObj -> Integer
  99 | 
 100 | %foreign "scheme:blodwen-id"
 101 | export
 102 | unsafeGetString : ForeignObj -> String
 103 | 
 104 | %foreign "scheme:blodwen-id"
 105 | export
 106 | unsafeGetFloat : ForeignObj -> Double
 107 | 
 108 | %foreign "scheme:blodwen-id"
 109 | export
 110 | unsafeGetChar : ForeignObj -> Char
 111 | 
 112 | %foreign "scheme:car"
 113 | export
 114 | unsafeFst : ForeignObj -> ForeignObj
 115 | 
 116 | %foreign "scheme:cdr"
 117 | export
 118 | unsafeSnd : ForeignObj -> ForeignObj
 119 | 
 120 | %foreign "scheme:blodwen-apply"
 121 | export
 122 | unsafeApply : ForeignObj -> ForeignObj -> ForeignObj
 123 | 
 124 | %foreign "scheme:blodwen-force"
 125 | export
 126 | unsafeForce : ForeignObj -> ForeignObj
 127 | 
 128 | %foreign "scheme:blodwen-vector-ref"
 129 | export
 130 | unsafeVectorRef : ForeignObj -> Integer -> ForeignObj
 131 | 
 132 | %foreign "scheme:blodwen-unbox"
 133 | export
 134 | unsafeUnbox : ForeignObj -> ForeignObj
 135 | 
 136 | %foreign "scheme:blodwen-vector-length"
 137 | export
 138 | unsafeVectorLength : ForeignObj -> Integer
 139 | 
 140 | %foreign "scheme:blodwen-vector-list"
 141 | export
 142 | unsafeVectorToList : ForeignObj -> List ForeignObj
 143 | 
 144 | %foreign "scheme:blodwen-make-symbol"
 145 | export
 146 | makeSymbol : String -> ForeignObj
 147 | 
 148 | %foreign "scheme:blodwen-read-symbol"
 149 | export
 150 | unsafeReadSymbol : ForeignObj -> String
 151 | 
 152 | export
 153 | evalSchemeStr : String -> IO (Maybe ForeignObj)
 154 | evalSchemeStr exp
 155 |     = let obj = prim__evalScheme exp in
 156 |           if prim__evalOkay obj == 1
 157 |              then pure $ Just (prim__evalResult obj)
 158 |              else pure Nothing
 159 | 
 160 | export
 161 | debugScheme : ForeignObj -> IO ()
 162 | debugScheme obj = primIO $ prim__debugScheme obj
 163 | 
 164 | public export
 165 | data Direction = Write | Readback
 166 | 
 167 | public export
 168 | data SchemeObj : Direction -> Type where
 169 |      Null : SchemeObj t
 170 |      Cons : SchemeObj t -> SchemeObj t -> SchemeObj t
 171 |      IntegerVal : Integer -> SchemeObj t
 172 |      FloatVal : Double -> SchemeObj t
 173 |      StringVal : String -> SchemeObj t
 174 |      CharVal : Char -> SchemeObj t
 175 |      Symbol : String -> SchemeObj t
 176 |      Box : SchemeObj t -> SchemeObj t
 177 |      Vector : Integer -> List (SchemeObj t) -> SchemeObj t
 178 |         -- ^ this is convenient for us since all our vectors start with a
 179 |         -- tag, but not for a general library
 180 | 
 181 |      Procedure : ForeignObj -> SchemeObj Readback
 182 | 
 183 |      Define : String -> SchemeObj Write -> SchemeObj Write
 184 |      Var : String -> SchemeObj Write
 185 |      Lambda : List String -> SchemeObj Write -> SchemeObj Write
 186 |      Let : String -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 187 |      If : SchemeObj Write -> SchemeObj Write -> SchemeObj Write ->
 188 |           SchemeObj Write
 189 |      Case : SchemeObj Write ->
 190 |             List (SchemeObj Write, SchemeObj Write) ->
 191 |             Maybe (SchemeObj Write) ->
 192 |             SchemeObj Write
 193 |      Cond : List (SchemeObj Write, SchemeObj Write) ->
 194 |             Maybe (SchemeObj Write) ->
 195 |             SchemeObj Write
 196 |      Apply : SchemeObj Write -> List (SchemeObj Write) -> SchemeObj Write
 197 | 
 198 | export
 199 | evalSchemeObj : SchemeObj Write -> IO (Maybe ForeignObj)
 200 | evalSchemeObj obj
 201 |     = do let str = toString obj
 202 |          evalSchemeStr str
 203 |   where
 204 |     showSep : String -> List String -> String
 205 |     showSep sep [] = ""
 206 |     showSep sep [x] = x
 207 |     showSep sep (x :: xs) = x ++ sep ++ showSep sep xs
 208 | 
 209 |     toString : SchemeObj Write -> String
 210 |     toString Null = "'()"
 211 |     toString (Cons x y) = "(cons " ++ toString x ++ " " ++ toString y ++ ")"
 212 |     toString (IntegerVal x) = show x
 213 |     toString (FloatVal x) = show x
 214 |     toString (StringVal x) = show x
 215 |     toString (CharVal x)
 216 |        = if (the Int (cast x) >= 32 && the Int (cast x) < 127)
 217 |             then "#\\" ++ cast x
 218 |             else "(integer->char " ++ show (the Int (cast x)) ++ ")"
 219 |     toString (Symbol x) = "'" ++ x
 220 |     toString (Vector i xs) = "(vector " ++ show i ++ " " ++ showSep " " (map toString xs) ++ ")"
 221 |     toString (Box x) = "(box " ++ toString x ++ ")"
 222 |     toString (Define x body) = "(define (" ++ x ++ ") " ++ toString body ++ ")"
 223 |     toString (Var x) = x
 224 |     toString (Lambda xs x)
 225 |         = "(lambda (" ++ showSep " " xs ++ ") " ++ toString x ++ ")"
 226 |     toString (Let var val x)
 227 |         = "(let ((" ++ var ++ " " ++ toString val ++ ")) " ++ toString x ++ ")"
 228 |     toString (If x t e)
 229 |         = "(if " ++ toString x ++ " " ++ toString t ++ " " ++ toString e ++ ")"
 230 |     toString (Case x alts def)
 231 |         = "(case " ++ toString x ++ " " ++
 232 |               showSep " " (map showAlt alts) ++
 233 |               showDef def ++ ")"
 234 |       where
 235 |         showAlt : (SchemeObj Write, SchemeObj Write) -> String
 236 |         showAlt (opt, go)
 237 |            = "((" ++ toString opt ++ ") " ++ toString go ++ ")"
 238 | 
 239 |         showDef : Maybe (SchemeObj Write) -> String
 240 |         showDef Nothing = ""
 241 |         showDef (Just e) = " (else " ++ toString e ++ ")"
 242 |     toString (Cond alts def)
 243 |         = "(cond " ++
 244 |               showSep " " (map showAlt alts) ++
 245 |               showDef def ++ ")"
 246 |       where
 247 |         showAlt : (SchemeObj Write, SchemeObj Write) -> String
 248 |         showAlt (opt, go)
 249 |            = "(" ++ toString opt ++ " " ++ toString go ++ ")"
 250 | 
 251 |         showDef : Maybe (SchemeObj Write) -> String
 252 |         showDef Nothing = ""
 253 |         showDef (Just e) = " (else " ++ toString e ++ ")"
 254 |     toString (Apply x xs)
 255 |         = "(" ++ toString x ++ " " ++ showSep " " (map toString xs) ++ ")"
 256 | 
 257 | export
 258 | decodeObj : ForeignObj -> SchemeObj Readback
 259 | decodeObj obj
 260 |     = if isInteger obj then IntegerVal (unsafeGetInteger obj)
 261 |       else if isVector obj then Vector (unsafeGetInteger (unsafeVectorRef obj 0))
 262 |                                        (readVector (unsafeVectorLength obj) 1 obj)
 263 |       else if isPair obj then Cons (decodeObj (unsafeFst obj))
 264 |                                    (decodeObj (unsafeSnd obj))
 265 |       else if isFloat obj then FloatVal (unsafeGetFloat obj)
 266 |       else if isString obj then StringVal (unsafeGetString obj)
 267 |       else if isChar obj then CharVal (unsafeGetChar obj)
 268 |       else if isSymbol obj then Symbol (unsafeReadSymbol obj)
 269 |       else if isProcedure obj then Procedure obj
 270 |       else if isBox obj then Box (decodeObj (unsafeUnbox obj))
 271 |       else Null
 272 |   where
 273 |     readVector : Integer -> Integer -> ForeignObj -> List (SchemeObj Readback)
 274 |     readVector len i obj
 275 |         = if len == i
 276 |              then []
 277 |              else decodeObj (unsafeVectorRef obj i) ::
 278 |                      readVector len (i + 1) obj
 279 | 
 280 | public export
 281 | interface Scheme a where
 282 |   toScheme : a -> SchemeObj Write
 283 |   fromScheme : SchemeObj Readback -> Maybe a
 284 | 
 285 | export
 286 | evalScheme : Scheme a => a -> IO (Maybe ForeignObj)
 287 | evalScheme = evalSchemeObj . toScheme
 288 | 
 289 | export
 290 | decode : Scheme a => ForeignObj -> Maybe a
 291 | decode = fromScheme . decodeObj
 292 | 
 293 | export
 294 | Scheme Integer where
 295 |   toScheme x = IntegerVal x
 296 | 
 297 |   fromScheme (IntegerVal x) = Just x
 298 |   fromScheme _ = Nothing
 299 | 
 300 | export
 301 | Scheme Int where
 302 |   toScheme x = IntegerVal (cast x)
 303 | 
 304 |   fromScheme (IntegerVal x) = Just (cast x)
 305 |   fromScheme _ = Nothing
 306 | 
 307 | export
 308 | Scheme Int8 where
 309 |   toScheme x = IntegerVal (cast x)
 310 | 
 311 |   fromScheme (IntegerVal x) = Just (cast x)
 312 |   fromScheme _ = Nothing
 313 | 
 314 | export
 315 | Scheme Int16 where
 316 |   toScheme x = IntegerVal (cast x)
 317 | 
 318 |   fromScheme (IntegerVal x) = Just (cast x)
 319 |   fromScheme _ = Nothing
 320 | 
 321 | export
 322 | Scheme Int32 where
 323 |   toScheme x = IntegerVal (cast x)
 324 | 
 325 |   fromScheme (IntegerVal x) = Just (cast x)
 326 |   fromScheme _ = Nothing
 327 | 
 328 | export
 329 | Scheme Int64 where
 330 |   toScheme x = IntegerVal (cast x)
 331 | 
 332 |   fromScheme (IntegerVal x) = Just (cast x)
 333 |   fromScheme _ = Nothing
 334 | 
 335 | export
 336 | Scheme Bits8 where
 337 |   toScheme x = IntegerVal (cast x)
 338 | 
 339 |   fromScheme (IntegerVal x) = Just (cast x)
 340 |   fromScheme _ = Nothing
 341 | 
 342 | export
 343 | Scheme Bits16 where
 344 |   toScheme x = IntegerVal (cast x)
 345 | 
 346 |   fromScheme (IntegerVal x) = Just (cast x)
 347 |   fromScheme _ = Nothing
 348 | 
 349 | export
 350 | Scheme Bits32 where
 351 |   toScheme x = IntegerVal (cast x)
 352 | 
 353 |   fromScheme (IntegerVal x) = Just (cast x)
 354 |   fromScheme _ = Nothing
 355 | 
 356 | export
 357 | Scheme Bits64 where
 358 |   toScheme x = IntegerVal (cast x)
 359 | 
 360 |   fromScheme (IntegerVal x) = Just (cast x)
 361 |   fromScheme _ = Nothing
 362 | 
 363 | export
 364 | Scheme String where
 365 |   toScheme x = StringVal x
 366 | 
 367 |   fromScheme (StringVal x) = Just x
 368 |   fromScheme _ = Nothing
 369 | 
 370 | export
 371 | Scheme Double where
 372 |   toScheme x = FloatVal x
 373 | 
 374 |   fromScheme (FloatVal x) = Just x
 375 |   fromScheme _ = Nothing
 376 | 
 377 | export
 378 | Scheme Char where
 379 |   toScheme x = CharVal x
 380 | 
 381 |   fromScheme (CharVal x) = Just x
 382 |   fromScheme _ = Nothing
 383 | 
 384 | export
 385 | Scheme Bool where
 386 |   toScheme False = IntegerVal 0
 387 |   toScheme True = IntegerVal 1
 388 | 
 389 |   fromScheme (IntegerVal 0) = Just False
 390 |   fromScheme (IntegerVal 1) = Just True
 391 |   fromScheme _ = Nothing
 392 | 
 393 | export
 394 | Scheme a => Scheme (List a) where
 395 |   toScheme [] = Null
 396 |   toScheme (x :: xs) = Cons (toScheme x) (toScheme xs)
 397 | 
 398 |   fromScheme Null = Just []
 399 |   fromScheme (Cons x xs) = Just $ !(fromScheme x) :: !(fromScheme xs)
 400 |   fromScheme _ = Nothing
 401 | 
 402 | export
 403 | (Scheme a, Scheme b) => Scheme (a, b) where
 404 |   toScheme (x, y) = Cons (toScheme x) (toScheme y)
 405 |   fromScheme (Cons x y) = Just (!(fromScheme x), !(fromScheme y))
 406 |   fromScheme _ = Nothing
 407 | 
 408 | export
 409 | Scheme a => Scheme (Maybe a) where
 410 |   toScheme Nothing = Null
 411 |   toScheme (Just x) = Box (toScheme x)
 412 | 
 413 |   fromScheme Null = Just Nothing
 414 |   fromScheme (Box x) = Just $ Just !(fromScheme x)
 415 |   fromScheme _ = Nothing
 416 |