diff --git a/core/Core.carp b/core/Core.carp index 3f02862ef..fbe03d76c 100644 --- a/core/Core.carp +++ b/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") diff --git a/core/Introspect.carp b/core/Introspect.carp new file mode 100644 index 000000000..3d71143a8 --- /dev/null +++ b/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)))))) +) diff --git a/src/Primitives.hs b/src/Primitives.hs index 197302225..8ba9016ef 100644 --- a/src/Primitives.hs +++ b/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 diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index 692efa327..a53158c63 100644 --- a/src/StartingEnv.hs +++ b/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))