Add s-exp primitive and Introspection module

core/Core.carp

@@ -18,6 +18,7 @@
 (load-once "Interfaces.carp")
 (load-once "Bool.carp")
 (load-once "Macros.carp")
+(load-once "Introspect.carp")
 (load-once "Pointer.carp")
 (load-once "Unsafe.carp")
 (load-once "Generics.carp")

core/Introspect.carp

@@ -0,0 +1,76 @@
+(doc Introspect
+  "Dynamic functions that return information about the s-expressions associated
+  to a binding.")
+(defmodule Introspect
+  (doc module?
+    "Is this binding a module?")
+  (defmacro module? [binding]
+    (not (list? (eval (list 's-expr binding)))))
+  (doc function? 
+    "Is this binding a function?")
+  (defmacro function? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+      (Dynamic.= (Symbol.from "defn") (car (eval (list 's-expr binding))))))
+  (doc variable?
+    "Is this binding a variable?")
+  (defmacro variable? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+      (Dynamic.= (Symbol.from "def") (car (eval (list 's-expr binding))))))
+  (doc type?
+    "Is this binding a type?")
+  (defmacro type? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+        (Dynamic.= (Symbol.from "deftype") (car (eval (list 's-expr binding))))))
+  (doc struct? 
+    "Is this binding a struct?")
+  (defmacro struct? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+        (array? (caddr (eval (list 's-expr binding))))))
+  (doc sumtype?
+    "Is this binding a sumtype?")
+  (defmacro sumtype? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+        (list? (caddr (eval (list 's-expr binding))))))
+  (doc arity 
+    "What's the arity of this binding?
+
+    - When `binding` is a function, returns the number of arguments.
+    - When `binding` is a struct, returns the number of fields.
+    - When `binding` is a sumtype, returns a list of the number of type
+      arguments of each constructor.")
+  (defmacro arity [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        0
+    (eval (list 'cond
+        (list 'Introspect.function? binding) (length (caddr (eval (list 's-expr binding))))
+        (list 'Introspect.struct? binding) (/ (length (caddr (eval (list 's-expr binding)))) 2)
+        (list 'Introspect.sumtype? binding) (quote (map (fn [arr]
+        (length (cadr arr))) (cddr (eval (list 's-expr binding)))))
+        0))))
+  (doc macro?
+    "Is this binding a macro?")
+  (defmacro macro? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+        (Dynamic.= (Symbol.from "defmacro") (car (eval (list 's-expr binding))))))
+  (doc dynamic?
+    "Is this binding a dynamic binding?")
+  (defmacro dynamic? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+        (or (Dynamic.= (Symbol.from "defdynamic") (car (eval (list 's-expr
+        binding))))
+            (Dynamic.= (Symbol.from "dynamic") (car (eval (list 's-expr
+        binding)))))))
+  (doc interface? 
+    "Is this binding an interface?")
+  (defmacro interface? [binding]
+    (if (empty? (eval (list 's-expr binding)))
+        false
+        (Dynamic.= (Symbol.from "definterface") (car (eval (list 's-expr binding))))))
+)

src/Primitives.hs

@@ -695,3 +695,45 @@ primitiveDeftemplate _ ctx [s@(XObj (Sym (SymPath _ _) _) _ _), _, _, _] = do
   argumentErr ctx "deftemplate" "a symbol without prefix" "first" s
 primitiveDeftemplate _ ctx [x, _, _, _] =
   argumentErr ctx "deftemplate" "a symbol" "first" x
+
+primitiveSexpression :: Primitive
+primitiveSexpression (XObj _ i _) ctx [XObj (Sym path _) _ _] =
+  let env = contextGlobalEnv ctx
+      tyEnv = getTypeEnv $ contextTypeEnv ctx
+  in case lookupInEnv path env of
+       Just (_, binder@(Binder _ xobj)) ->
+         case xobj of
+         -- Normally, modules print their names, we actually want the deftype
+         -- form here.
+         mod@(XObj (Mod env) _ _) ->
+           case lookupInEnv path tyEnv of
+             Just (_, Binder _ (XObj (Lst forms) i t)) ->
+               return (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
+             Just (_, Binder _ xobj') ->
+               return (ctx, Right xobj')
+             -- Okay, this is just a `defmodule` not a type.
+             Nothing ->
+               return (ctx, Right mod)
+         (XObj (Lst forms) i t) ->
+           return (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
+         _ -> return (ctx, Right xobj)
+       Nothing ->
+         -- Just to be sure, check the type env--this might be an interface or
+         -- type
+         case lookupInEnv path tyEnv of
+           Just (_, Binder _ (XObj (Lst forms) i t)) ->
+               return (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
+           Just (_, Binder _ xobj'') ->
+             return (ctx, Right xobj'')
+           Nothing -> return (ctx, Right (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
+primitiveSexpression (XObj _ i _) ctx xobj =
+  return $ evalError ctx ("s-exp expected a symbol argument but got: " ++ unwords (map pretty xobj)) i
+
+toSymbols :: XObj -> XObj
+toSymbols (XObj (Defn _) i t) = (XObj (Sym (SymPath [] "defn") Symbol) i t)
+toSymbols (XObj Def i t) = (XObj (Sym (SymPath [] "def") Symbol) i t)
+toSymbols (XObj (Deftype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)
+toSymbols (XObj (DefSumtype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)
+toSymbols (XObj (Interface _ _) i t) = (XObj (Sym (SymPath [] "definterface") Symbol) i t)
+toSymbols (XObj Macro i t) = (XObj (Sym (SymPath [] "defmacro") Symbol) i t)
+toSymbols x = x

src/StartingEnv.hs

@@ -248,6 +248,7 @@ dynamicModule = Env { envBindings = bindings
                     , makePrim "defined?" 1 "checks whether a symbol is defined." "(defined? mysymbol)" primitiveDefined
                     , makePrim "deftemplate" 4 "defines a new C template." "(deftemplate symbol Type declString defString)" primitiveDeftemplate
                     , makePrim "implements" 2 "designates a function as an implementation of an interface." "(implements zero Maybe.zero)" primitiveImplements
+                    , makePrim "s-expr" 1 "returns the s-expression associated with a binding. When the binding is a type, the deftype form is returned instead of the type's module." "(s-expr foo)" primitiveSexpression
                     ]
                     ++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
                        ,("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing))