Merge pull request #939 from scolsen/reify

Enhance type reflection
2024-08-15 16:20:40 +03:00 · 2020-10-06 19:54:47 +02:00 · 2020-10-06 19:54:47 +02:00 · 772051ede9
commit 772051ede9
parent f34cf47693 4519b77161
10 changed files with 191 additions and 107 deletions
--- a/CarpHask.cabal
+++ b/CarpHask.cabal
@ -54,7 +54,8 @@ library
                       Path,
                       Interfaces,
                       Primitives,
-                       Validate
+                       Validate,
+                       Reify

  build-depends:       base >= 4.7 && < 5
                     , parsec == 3.1.*
--- a/docs/core/Dynamic.html
+++ b/docs/core/Dynamic.html
@ -458,7 +458,14 @@
                    (all? f xs)
                </pre>
                <p class="doc">
-                    
+                    <p>Checks whether all of the elements in <code>xs</code> conform to the predicate
+function <code>f</code>.</p>
+<pre><code>(all? (fn [x] (&lt; 1 x)) '(2 3 4))
+=&gt; true
+(all? (fn [x] (&lt; 1 x)) '(-1 0 1))
+=&gt; false
+</code></pre>
+
                </p>
            </div>
            <div class="binder">
@ -477,11 +484,12 @@
                    (any? f xs)
                </pre>
                <p class="doc">
-                    <p>checks whether all of the elements in <code>xs</code> conform to the predicate
+                    <p>Checks whether any of the elements in <code>xs</code> conforms to the predicate
 function <code>f</code>.</p>
-<p>Example:</p>
-<pre><code>(all? (fn [x] (&lt; 1 x)) '(2 3 4)) ; =&gt; true
-(all? (fn [x] (&lt; 1 x)) '(-1 0 1)) ; =&gt; false
+<pre><code>(any? (fn [x] (= 'a x)) '(a b c))
+=&gt; true
+(any? (fn [x] (= 'a x)) '(e f g))
+=&gt; false
 </code></pre>

                </p>
@ -1331,7 +1339,6 @@ result.</p>
 <p>If you only need to compose functions that take a single argument (unary arity)
 see <code>comp</code>. Comp also generates the form that corresponds to the composition,
 compose contrarily evaluates 'eagerly' and returns a computed symbol.</p>
-<p>For exmaple:</p>
 <pre><code>;; a silly composition
 ((compose empty take) 3 [1 2 3 4 5])
 ;; =&gt; []
@ -1408,11 +1415,10 @@ compose contrarily evaluates 'eagerly' and returns a computed symbol.</p>
                    (curry f x)
                </pre>
                <p class="doc">
-                    <p>Returns a curried function accepting a single argument, that applies f to x
+                    <p>Returns a curried function accepting a single argument, that applies <code>f</code> to <code>x</code>
 and then to the following argument.</p>
-<p>For example,</p>
 <pre><code>(map (curry Symbol.prefix 'Foo) '(bar baz))
-;; =&gt; (Foo.bar Foo.baz)
+=&gt; (Foo.bar Foo.baz)
 </code></pre>

                </p>
@ -1434,16 +1440,15 @@ and then to the following argument.</p>
                </pre>
                <p class="doc">
                    <p>Curry functions of any airity.</p>
-<p>For example:</p>
 <pre><code>(map (curry* Dynamic.zip + '(1 2 3)) '((4 5) (6)))
-;; =&gt; (((+ 1 4) (+ 2 5)) ((+ 1 6)))
+=&gt; (((+ 1 4) (+ 2 5)) ((+ 1 6)))

 ((curry Dynamic.zip cons '(1 2 3)) '((4 5) (6)))
-;; =&gt; ((cons 1 (4 5)) (cons (2 (6))))
+=&gt; ((cons 1 (4 5)) (cons (2 (6))))

 (defndynamic add-em-up [x y z] (+ (+ x y) z))
 (map (curry* add-em-up 1 2) '(1 2 3))
-;; =&gt; (4 5 6)
+=&gt; (4 5 6)
 </code></pre>

                </p>
@ -1730,11 +1735,10 @@ and then to the following argument.</p>
                </pre>
                <p class="doc">
                    <p>Returns the empty form of <code>xs</code>.</p>
-<p>For example:</p>
 <pre><code>(empty '(1 2 3 4))
-;; =&gt; ()
+=&gt; ()
 (empty '[1 2 3 4])
-;; =&gt; []
+=&gt; []
 </code></pre>

                </p>
@ -1907,9 +1911,8 @@ and then to the following argument.</p>
                <p class="doc">
                    <p>Returns a list containing only the elements of <code>xs</code> that satisify
 predicate <code>p</code>.</p>
-<p>For example:</p>
 <pre><code>(filter (fn [x] (= 'a x)) '(a b a b a b a b))
-;; =&gt; (a a a a)
+=&gt; (a a a a)
 </code></pre>

                </p>
@ -1930,10 +1933,9 @@ predicate <code>p</code>.</p>
                    (flatten l)
                </pre>
                <p class="doc">
-                    <p>flattens a list recursively.</p>
-<p>For example:</p>
+                    <p>Flattens a list recursively.</p>
 <pre><code>(flatten '(1 2 (3 (4))))
-; =&gt; '(1 2 3 4)
+=&gt; '(1 2 3 4)
 </code></pre>

                </p>
@ -1955,9 +1957,8 @@ predicate <code>p</code>.</p>
                </pre>
                <p class="doc">
                    <p>Flips the arguments of a function <code>f</code>.</p>
-<p>For example,</p>
 <pre><code>((flip Symbol.prefix) 'Bar 'Foo)
-=&gt; ;; (Foo.Bar)
+=&gt; (Foo.Bar)
 </code></pre>

                </p>
@ -2046,6 +2047,29 @@ predicate <code>p</code>.</p>
                    <p>prints all information associated with a symbol.</p>
 <p>Example Usage:</p>
 <pre><code>(info mysymbol)
+</code></pre>
+
+                </p>
+            </div>
+            <div class="binder">
+                <a class="anchor" href="#kind">
+                    <h3 id="kind">
+                        kind
+                    </h3>
+                </a>
+                <div class="description">
+                    primitive
+                </div>
+                <p class="sig">
+                    Dynamic
+                </p>
+                <span>
+                    
+                </span>
+                <p class="doc">
+                    <p>prints the kind of a symbol.</p>
+<p>Example Usage:</p>
+<pre><code>(kind mysymbol)
 </code></pre>

                </p>
@ -2142,25 +2166,6 @@ predicate <code>p</code>.</p>

                </p>
            </div>
-            <div class="binder">
-                <a class="anchor" href="#list-to-array-internal">
-                    <h3 id="list-to-array-internal">
-                        list-to-array-internal
-                    </h3>
-                </a>
-                <div class="description">
-                    dynamic
-                </div>
-                <p class="sig">
-                    Dynamic
-                </p>
-                <pre class="args">
-                    (list-to-array-internal xs acc)
-                </pre>
-                <p class="doc">
-                    
-                </p>
-            </div>
            <div class="binder">
                <a class="anchor" href="#list?">
                    <h3 id="list?">
@ -2295,8 +2300,7 @@ predicate <code>p</code>.</p>
                    <p>Applies a function <code>f</code> to each element in the list or array <code>xs</code> and
 returns a list dynamic data literal containing the result of the function
 applications.</p>
-<p>For example:</p>
-<pre><code class="language-clojure">'(map symbol? '(a b c))
+<pre><code>'(map symbol? '(a b c))
 =&gt; (true true true)
 '(map (curry + 1) '(1 2 3))
 =&gt; (2 3 4)
@ -2875,10 +2879,9 @@ value through successive applications of <code>f</code>.</p>
                    (take n xs)
                </pre>
                <p class="doc">
-                    <p>Returns a list containing the first <code>n</code> eleements of a list.</p>
-<p>For example:</p>
+                    <p>Returns a list containing the first <code>n</code> elements of a list.</p>
 <pre><code>(take 3 '(1 2 3 4 5))
-;; =&gt; (1 2 3)
+=&gt; (1 2 3)
 </code></pre>

                </p>
@ -2925,9 +2928,8 @@ value through successive applications of <code>f</code>.</p>
                    <p>Applies <code>f</code> to a starting value <code>x</code>, then generates a sequence of values
 by successively applying <code>f</code> to the result <code>lim-1</code> times.
 Collects results in the structure given by <code>acc</code>.</p>
-<p>For example:</p>
 <pre><code>(unreduce (curry + 1) 0 10 (list))
-;; =&gt; (1 2 3 4 5 6 7 8 9 10)
+=&gt; (1 2 3 4 5 6 7 8 9 10)
 </code></pre>

                </p>
@ -2995,22 +2997,21 @@ Collects results in the structure given by <code>acc</code>.</p>
                </pre>
                <p class="doc">
                    <p>Returns the <em>form</em> that results from applying  a function <code>f</code> to each of
-the values supplied in <code>forms</code>.</p>
-<p>If the members of a single form are exhuasted, the result of the
+the values supplied in <code>forms</code>.
+If the members of a single form are exhuasted, the result of the
 applications thus far is returned, and any remaining members in the other
 forms are ignored.</p>
-<p>For example,</p>
 <pre><code>(zip + '(1 2 3) '(4 5 6))
-;; =&gt; ((+ 1 4) (+ 2 5) (+ 3 6))
+=&gt; ((+ 1 4) (+ 2 5) (+ 3 6))
 </code></pre>
 <p>It's important to note that zip operates on forms, and that the form
 returned by zip may not be evaluable by itself. For instance, to actually
 transform the result in the example above into something Carp can
 evaluate, we need to wrap each member of the list in a <code>do</code>:</p>
 <pre><code>(append (list 'do) (zip + '(1 2 3) '(4 5 6)))
-;; =&gt; (do (+ 1 4) (+ 2 5) (+ 3 6))
+=&gt; (do (+ 1 4) (+ 2 5) (+ 3 6))
 (eval (append (list 'do) (zip + '(1 2 3) '(4 5 6))))
-;; =&gt; 9 ;; do returns the value of the last form in its body
+=&gt; 9 ;; do returns the value of the last form in its body
 </code></pre>

                </p>
--- a/headerparse/Main.hs
+++ b/headerparse/Main.hs
@ -11,6 +11,7 @@ import Util
 import Types
 import Obj
 import Path
+import Reify

 data Args = Args { prefixToRemove :: String
                 , kebabCase :: Bool
@ -159,7 +160,7 @@ createRegisterForm name tyXObj prefix kebab =
 toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj
 toFnTypeXObj argTypeStrings returnTypeString =
  (XObj (Lst [ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing)
-             , (XObj (Arr (map (tyToXObj . cTypeToCarpType) argTypeStrings)) Nothing Nothing)
+             , (XObj (Arr (map (reify . cTypeToCarpType) argTypeStrings)) Nothing Nothing)
             , (XObj (Sym (SymPath [] (show (cTypeToCarpType returnTypeString))) Symbol) Nothing Nothing)
             ]) Nothing Nothing)

--- a/src/Commands.hs
+++ b/src/Commands.hs
@ -29,6 +29,8 @@ import TypeError
 import Path
 import Info
 import qualified Meta
+import Reify
+

 data CarpException =
    ShellOutException { shellOutMessage :: String, returnCode :: Int }
@ -933,7 +935,7 @@ commandSexpressionInternal ctx [xobj] bol =
      tyEnv = getTypeEnv $ contextTypeEnv ctx
  in case xobj of
       (XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
-         return (ctx, Right (XObj (Lst [(toSymbols inter), path, (tyToXObj ty)]) i t))
+         return (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t))
       (XObj (Lst forms) i t) ->
         return (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
       mod@(XObj (Mod e) i t) ->
--- a/src/Concretize.hs
+++ b/src/Concretize.hs
@ -23,6 +23,7 @@ import ToTemplate
 import Validate
 import SumtypeCase
 import Info
+import Reify

 data Level = Toplevel | Inside

@ -130,7 +131,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                 -- The lambda will also carry with it a special made struct containing the variables it captures
                 -- (if it captures at least one variable)
                 structMemberPairs = concatMap (\(XObj (Sym path _) _ (Just symTy)) ->
-                                                  [XObj (Sym path Symbol) Nothing Nothing, tyToXObj symTy])
+                                                  [XObj (Sym path Symbol) Nothing Nothing, reify symTy])
                                     capturedVars
                 environmentTypeName = pathToC lambdaPath ++ "_env"
                 environmentStructTy = StructTy (ConcreteNameTy environmentTypeName) []
@ -482,6 +483,24 @@ depsForCase typeEnv x@(XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
    members
 depsForCase _ x = Left (InvalidSumtypeCase x)

+replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
+replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
+  concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs)
+
+replaceGenericTypeSymbols :: Map.Map String Ty -> XObj -> XObj
+replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath pathStrings name) _) i t) =
+  let Just perhapsTyVar = xobjToTy xobj
+  in if isFullyGenericType perhapsTyVar
+     then case Map.lookup name mappings of
+            Just found -> reify found
+            Nothing -> xobj -- error ("Failed to concretize member '" ++ name ++ "' at " ++ prettyInfoFromXObj xobj ++ ", mappings: " ++ show mappings)
+     else xobj
+replaceGenericTypeSymbols mappings (XObj (Lst lst) i t) =
+  XObj (Lst (map (replaceGenericTypeSymbols mappings) lst)) i t
+replaceGenericTypeSymbols mappings (XObj (Arr arr) i t) =
+  XObj (Arr (map (replaceGenericTypeSymbols mappings) arr)) i t
+replaceGenericTypeSymbols _ xobj = xobj
+
 replaceGenericTypeSymbolsOnCase :: Map.Map String Ty -> XObj -> XObj
 replaceGenericTypeSymbolsOnCase mappings singleCase@(XObj (Lst (caseName : caseMembers)) i t) =
  XObj (Lst (caseName : map replacer caseMembers)) i t
--- a/src/Obj.hs
+++ b/src/Obj.hs
@ -494,35 +494,6 @@ fromJustWithErrorMessage :: Maybe Ty -> String -> Ty
 fromJustWithErrorMessage (Just x) _ = x
 fromJustWithErrorMessage Nothing msg = error msg

-replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
-replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
-  concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs)
-
-replaceGenericTypeSymbols :: Map.Map String Ty -> XObj -> XObj
-replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath pathStrings name) _) i t) =
-  let Just perhapsTyVar = xobjToTy xobj
-  in if isFullyGenericType perhapsTyVar
-     then case Map.lookup name mappings of
-            Just found -> tyToXObj found
-            Nothing -> xobj -- error ("Failed to concretize member '" ++ name ++ "' at " ++ prettyInfoFromXObj xobj ++ ", mappings: " ++ show mappings)
-     else xobj
-replaceGenericTypeSymbols mappings (XObj (Lst lst) i t) =
-  XObj (Lst (map (replaceGenericTypeSymbols mappings) lst)) i t
-replaceGenericTypeSymbols mappings (XObj (Arr arr) i t) =
-  XObj (Arr (map (replaceGenericTypeSymbols mappings) arr)) i t
-replaceGenericTypeSymbols _ xobj = xobj
-
-- | Convert a Ty to the s-expression that represents that type.
-- | TODO: Add more cases and write tests for this.
-tyToXObj :: Ty -> XObj
-tyToXObj (StructTy n []) = tyToXObj n
-tyToXObj (StructTy n vs) = XObj (Lst (tyToXObj n : map tyToXObj vs)) Nothing Nothing
-tyToXObj (RefTy t lt) = XObj (Lst [XObj (Sym (SymPath [] "Ref") Symbol) Nothing Nothing, tyToXObj t, tyToXObj lt]) Nothing Nothing
-tyToXObj (PointerTy t) = XObj (Lst [XObj (Sym (SymPath [] "Ptr") Symbol) Nothing Nothing, tyToXObj t]) Nothing Nothing
-tyToXObj (FuncTy argTys returnTy StaticLifetimeTy) = XObj (Lst [XObj (Sym (SymPath [] "Fn") Symbol) Nothing Nothing, XObj (Arr (map tyToXObj argTys)) Nothing Nothing, tyToXObj returnTy]) Nothing Nothing
-tyToXObj (FuncTy argTys returnTy lt) = XObj (Lst [XObj (Sym (SymPath [] "Fn") Symbol) Nothing Nothing, XObj (Arr (map tyToXObj argTys)) Nothing Nothing, tyToXObj returnTy, tyToXObj lt]) Nothing Nothing
-tyToXObj x = XObj (Sym (SymPath [] (show x)) Symbol) Nothing Nothing
-
 -- | Helper function to create binding pairs for registering external functions.
 register :: String -> Ty -> (String, Binder)
 register name t = (name, Binder emptyMeta
--- a/src/Primitives.hs
+++ b/src/Primitives.hs
@ -4,7 +4,7 @@ import Control.Monad (unless, when, foldM)
 import Control.Monad.IO.Class (liftIO)
 import Data.List (foldl')
 import Data.Maybe (fromMaybe)
-import Data.Either (isRight)
+import Data.Either (isRight, rights)

 import ColorText
 import Commands
@ -24,6 +24,8 @@ import ToTemplate
 import Info
 import qualified Meta as Meta
 import Interfaces
+import Infer
+import Reify

 import Debug.Trace

@ -320,22 +322,6 @@ dynamicOrMacroWith ctx producer ty name body = do
      meta = existingMeta globalEnv elem
  return (ctx { contextGlobalEnv = envInsertAt globalEnv path (Binder meta elem) }, dynamicNil)

-primitiveType :: Primitive
-primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
-  maybe otherDefs (found ctx . snd) (lookupInEnv path env)
-  where env = contextGlobalEnv ctx
-        otherDefs = case multiLookupALL name env of
-                      [] ->
-                        notFound ctx x path
-                      binders ->
-                        liftIO $ do mapM_ (\(env, binder) -> putStrLnWithColor White (show binder)) binders
-                                    return (ctx, dynamicNil)
-primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
-  maybe (notFound ctx x qualifiedPath) (found ctx . snd) (lookupInEnv qualifiedPath env)
-  where env = contextGlobalEnv ctx
-primitiveType _ ctx [x] =
-  return (evalError ctx ("Can't get the type of non-symbol: " ++ pretty x) (info x))
-
 primitiveMembers :: Primitive
 primitiveMembers _ ctx [target] = do
  let env = contextEnv ctx
@ -452,7 +438,7 @@ registerInternal ctx name ty override =
                          registration = XObj (Lst [XObj (External override) Nothing Nothing
                                                   ,XObj (Sym path Symbol) Nothing Nothing
                                                   ,ty
-						   ]) (info ty) (Just t)
+                                                   ]) (info ty) (Just t)
                          meta = existingMeta globalEnv registration
                          env' = envInsertAt globalEnv path (Binder meta registration)
                      in  (ctx { contextGlobalEnv = env' }, dynamicNil)
@ -641,3 +627,64 @@ 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
+
+noTypeError :: Context -> XObj -> IO (Context, Either EvalError XObj)
+noTypeError ctx x = return $ evalError ctx ("Can't get the type of: " ++ pretty x) (info x)
+
+primitiveType :: Primitive
+-- A special case, the type of the type of types (type (type (type 1))) => ()
+primitiveType _ ctx [x@(XObj _ _ (Just Universe))] =
+  return (ctx, Right (XObj (Lst []) Nothing Nothing))
+primitiveType _ ctx [x@(XObj _ _ (Just TypeTy))] = liftIO $ return (ctx, Right $ reify TypeTy)
+primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
+  (maybe otherDefs (go ctx . snd) (lookupInEnv path env))
+  where env = contextGlobalEnv ctx
+        otherDefs = case multiLookupALL name env of
+                      [] ->
+                        notFound ctx x path
+                      binders ->
+                        (sequence (map (go ctx . snd) binders))
+                        >>= return . Lst . rights . map snd
+                        >>= \obj -> return (ctx, Right $ (XObj obj Nothing Nothing))
+        go ctx binder =
+          case (ty (binderXObj binder))of
+            Nothing -> noTypeError ctx x
+            Just t -> return (ctx, Right (reify t))
+primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
+  maybe (notFound ctx x qualifiedPath) (go ctx . snd) (lookupInEnv qualifiedPath env)
+  where env = contextGlobalEnv ctx
+        go ctx binder =
+          case (ty (binderXObj binder)) of
+            Nothing -> noTypeError ctx x
+            Just t -> return (ctx, Right $ reify t)
+-- As a special case, we force evaluation on sequences such as (type (type 1))
+-- Because primitives don't evaluate their arguments, passing (type 1) to type would result in an error
+-- However, such an invocation *is* meaningful, and returns Type (the type of types). (type (type 1)) => Type
+-- Note that simply making type a command as an alternative leads to inconsistent behaviors whereby
+-- (type 1) => Int
+-- (type '1) => Int
+-- (type (Pair.init 1 1)) => Error can't find symbol "type"
+-- (type '(Pair.init 1 1)) => (Pair Int Int)
+-- Contrarily the behavior is far more consistent as a primitive if we simply add this case, and from a user perspective, it makes more sense
+-- that this function would be one that *doesn't* evaluate its arguments.
+primitiveType any ctx [x@(XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _: rest)) _ _)] =
+  primitiveType any ctx rest
+  >>= \result -> case snd result of
+                 Right xobj -> primitiveType any (fst result) [xobj]
+                 Left e -> return (ctx, Left e)
+primitiveType _ ctx [x@(XObj _ _ _)] =
+  let tenv  = contextTypeEnv ctx
+      typed = annotate tenv (contextGlobalEnv ctx) x Nothing
+  in  liftIO $ either fail ok typed
+  where fail e = return (evalError ctx ("Can't get the type of: " ++ pretty x) (info x))
+        ok ((XObj _ _ (Just t)),_) = return (ctx, Right $ reify t)
+        ok (_,_) = return (evalError ctx ("Can't get the type of: " ++ pretty x) (info x))
+
+primitiveKind :: Primitive
+primitiveKind _ ctx [x@(XObj _ _ _)] =
+  let tenv = contextTypeEnv ctx
+      typed = annotate tenv (contextGlobalEnv ctx) x Nothing
+  in  return (either fail ok typed)
+  where fail e = (evalError ctx ("Can't get the kind of: " ++ pretty x) (info x))
+        ok (XObj _ _ (Just t), _) = (ctx, Right $ reify (tyToKind t))
+        ok (_, _) = (evalError ctx ("Can't get the kind of: " ++ pretty x) (info x))
--- a/src/Reify.hs
+++ b/src/Reify.hs
@ -0,0 +1,38 @@
+-- | Module Reify provides a typeclass and instances for turning internal compiler types and data into
+-- corresponding representations in the Carp language.
+module Reify where
+
+import Types
+import Obj
+
+-- | The Reifiable class ranges over internal Carp compiler types that 
+-- may have corresponding representations in Carp itself.
+class Reifiable a where
+  reify :: a -> XObj
+
+symbol :: Show a => a -> XObj
+symbol x = XObj (Sym (SymPath [] (show x)) Symbol) Nothing Nothing
+
+-- Show on strings results in a symbol that includes quotes ""
+-- This function is the same as symbol, for string literals.
+literal :: String -> XObj 
+literal x = XObj (Sym (SymPath [] x) Symbol) Nothing Nothing
+
+array :: (Reifiable a) => [a] -> XObj
+array x = XObj (Arr (map reify x)) Nothing Nothing
+
+lifetime :: Show a => a -> XObj
+lifetime x = literal ("<" ++ show x ++ ">")
+
+-- Types
+instance Reifiable Kind where
+  reify k = symbol k
+
+instance Reifiable Ty where
+  reify (StructTy t []) = reify t
+  reify (StructTy t vs) = XObj (Lst (reify t : map reify vs)) Nothing (Just TypeTy)
+  reify (RefTy t lt) = XObj (Lst [literal "Ref", reify t, lifetime lt]) Nothing (Just TypeTy)
+  reify (PointerTy t) = XObj (Lst [literal "Ptr", reify t]) Nothing (Just TypeTy)
+  reify (FuncTy ats rt lt) = XObj (Lst [literal "Fn", array ats, reify rt, lifetime lt]) Nothing (Just TypeTy)
+  reify TypeTy = XObj (Sym (SymPath [] (show TypeTy)) Symbol) Nothing (Just Universe)
+  reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy)
--- a/src/StartingEnv.hs
+++ b/src/StartingEnv.hs
@ -237,7 +237,6 @@ dynamicModule = Env { envBindings = bindings
                    , makePrim "defmacro" 3 "defines a new macro." "(defmacro name [args :rest restargs] body)" primitiveDefmacro
                    , makePrim "defndynamic" 3 "defines a new dynamic function, i.e. a function available at compile time." "(defndynamic name [args] body)" primitiveDefndynamic
                    , makePrim "defdynamic" 2 "defines a new dynamic value, i.e. a value available at compile time." "(defdynamic name value)" primitiveDefdynamic
-                    , makePrim "type" 1 "prints the type of a symbol." "(type mysymbol)" primitiveType
                    , makePrim "members" 1 "returns the members of a type as an array." "(members MyType)" primitiveMembers
                    , makeVarPrim "defmodule" "defines a new module in which `expressions` are defined." "(defmodule MyModule <expressions>)" primitiveDefmodule
                    , makePrim "meta-set!" 3 "sets a new key and value pair on the meta map associated with a symbol." "(meta-set! mysymbol \"mykey\" \"myval\")" primitiveMetaSet
@ -250,6 +249,8 @@ 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 "type" 1 "prints the type of a symbol." "(type mysymbol)" primitiveType
+                    , makePrim "kind" 1 "prints the kind of a symbol." "(kind mysymbol)" primitiveKind
                    ]
                    ++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
                       ,("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing))
--- a/src/Types.hs
+++ b/src/Types.hs
@ -18,6 +18,8 @@ module Types ( TypeMappings
             , mangle
             , pathToC
             , consPath
+             , Kind
+             , tyToKind
             ) where

 import qualified Data.Map as Map
@ -49,6 +51,7 @@ data Ty = IntTy
        | MacroTy
        | DynamicTy -- the type of dynamic functions (used in REPL and macros)
        | InterfaceTy
+        | Universe -- the type of types of types (the type of TypeTy)
        deriving (Eq, Ord)

 -- | Kinds checking