feat: Emit docs for top level bindings (#1253)

* refactor: Tiny cleanup before we begin

* refactor: Moved module finding to its own local function

* feat: save-docs-internal is now a binary command

* feat: This seems to work

* fix: Cleaned up the code, save-docs now emit one module per file listed

core/Macros.carp

@@ -270,10 +270,6 @@
     (list 'System.abort)
     (list 'bottom)))
 
-(defmacro save-docs [:rest modules]
-  ;; A trick to be able to send unquoted symbols to 'save-docs'
-  (eval (list 'save-docs-internal (list 'quote modules))))
-
 (defndynamic implement-declaration [mod interface]
   (list 'implements interface (Symbol.prefix mod interface)))
 

core/Project.carp

@@ -7,3 +7,9 @@
 (doc defproject "Define a project configuration.")
 (defmacro defproject [:rest bindings]
   (project-config bindings))
+
+(doc save-docs "A simple version of `save-docs-ex` that lets you list all the modules directly as unquoted symbols. Does not handle global symbols, use `save-docs-ex` for that.
+
+Example usage: `(save-docs Int Float String)`")
+(defmacro save-docs [:rest modules]
+  (eval (list 'save-docs-ex (list quote (collect-into modules array)) [])))

docs/core/generate_core_docs.carp

@@ -14,42 +14,45 @@
 (load "Bench.carp")
 (load "Phantom.carp")
 
-(save-docs Array
+(save-docs-ex
-           Bench
+ ['Array
-           Bool
+  'Bench
-           Byte
+  'Bool
-           Char
+  'Byte
-           Control
+  'Char
-           Debug
+  'Control
-           Derive
+  'Debug
-           Double
+  'Derive
-           Dynamic
+  'Double
-           Float
+  'Dynamic
-           Function
+  'Float
-           Geometry
+  'Function
-           Quasiquote
+  'Geometry
-           Int
+  'Quasiquote
-           Introspect
+  'Int
-           Unit
+  'Introspect
-           IO
+  'Unit
-           Long
+  'IO
-           Map
+  'Long
-           Maybe
+  'Map
-           Opaque
+  'Maybe
-           Pair
+  'Opaque
-           Pattern
+  'Pair
-           Quadruple
+  'Pattern
-           Phantom
+  'Quadruple
-           Pointer
+  'Phantom
-           Result
+  'Pointer
-           StaticArray
+  'Result
-           System
+  'StaticArray
-           Statistics
+  'System
-           String
+  'Statistics
-           Test
+  'String
-           Triple
+  'Test
-           Vector2
+  'Triple
-           Vector3
+  'Vector2
-           VectorN)
+  'Vector3
+  'VectorN]
+ ["Macros.carp"
+  "ControlMacros.carp"])
 
 (quit)

docs/sdl/generate_sdl_docs.carp

@@ -10,12 +10,18 @@
 (load "SDL_mixer.carp")
 (load "SDL_ttf.carp")
 
-(save-docs SDL
+(save-docs-ex
-           SDLApp
+ ['SDL
-           IMG
+  'SDLApp
-           GFX
+  'IMG
-           Mixer
+  'GFX
-           TTF
+  'Mixer
-           )
+  'TTF]
+ ["SDL.carp"
+  "SDL_image.carp"
+  "SDL_gfx.carp"
+  "SDL_mixer.carp"
+  "SDL_ttf.carp"
+  ])
 
 (quit)

src/Commands.hs

@@ -50,9 +50,9 @@ boolToXObj b = if b then trueXObj else falseXObj
 
 addCmd :: SymPath -> CommandFunctionType -> String -> String -> (String, Binder)
 addCmd path callback doc example =
-  (name, Binder meta cmd)
+  (filename, Binder meta cmd)
   where
-    SymPath _ name = path
+    SymPath _ filename = path
     exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n"
     docString = doc ++ "\n\n" ++ exampleUsage
     meta = Meta.set "doc" (XObj (Str docString) Nothing Nothing) emptyMeta
@@ -383,7 +383,7 @@ commandProject ctx = do
   liftIO (print (contextProj ctx))
   pure (ctx, dynamicNil)
 
--- | Command for getting the name of the operating system you're on.
+-- | Command for getting the filename of the operating system you're on.
 commandHostOS :: NullaryCommandCallback
 commandHostOS ctx =
   pure (ctx, Right (XObj (Str os) (Just dummyInfo) (Just StringTy)))
@@ -736,22 +736,58 @@ commandHostBitWidth ctx =
   let bitSize = Integral (finiteBitSize (undefined :: Int))
    in pure (ctx, Right (XObj (Num IntTy bitSize) (Just dummyInfo) (Just IntTy)))
 
-commandSaveDocsInternal :: UnaryCommandCallback
+commandSaveDocsEx :: BinaryCommandCallback
-commandSaveDocsInternal ctx modulePath = do
+commandSaveDocsEx ctx modulePaths filePaths = do
-  let globalEnv = contextGlobalEnv ctx
+  case modulesAndGlobals of
-  case modulePath of
+    Left err -> pure (ctx, Left err)
-    XObj (Lst xobjs) _ _ ->
+    Right ok -> saveDocs ctx ok
-      case mapM unwrapSymPathXObj xobjs of
-        Left err -> pure (evalError ctx err (xobjInfo modulePath))
-        Right okPaths ->
-          case mapM (getEnvironmentBinderForDocumentation ctx globalEnv) okPaths of
-            Left err -> pure (evalError ctx err (xobjInfo modulePath))
-            Right okEnvBinders -> saveDocs ctx (zip okPaths okEnvBinders)
-    x ->
-      pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (xobjInfo modulePath))
   where
-    getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
+    globalEnv = contextGlobalEnv ctx
-    getEnvironmentBinderForDocumentation _ env path =
+
+    modulesAndGlobals =
+      let (_, mods) = modules
+          (_, globs) = filesWithGlobals
+       in do
+            okMods <- mods
+            okGlobs <- globs
+            pure (okMods ++ okGlobs)
+
+    modules :: (Context, Either EvalError [(SymPath, Binder)])
+    modules = do
+      case modulePaths of
+        XObj (Arr xobjs) _ _ ->
+          case mapM unwrapSymPathXObj xobjs of
+            Left err -> evalError ctx err (xobjInfo modulePaths)
+            Right okPaths ->
+              case mapM (getEnvironmentBinderForDocumentation globalEnv) okPaths of
+                Left err -> evalError ctx err (xobjInfo modulePaths)
+                Right okEnvBinders -> (ctx, Right (zip okPaths okEnvBinders))
+        x ->
+          evalError ctx ("Invalid first arg to save-docs-internal (expected array of symbols): " ++ pretty x) (xobjInfo modulePaths)
+
+    filesWithGlobals :: (Context, Either EvalError [(SymPath, Binder)])
+    filesWithGlobals = do
+      case filePaths of
+        XObj (Arr xobjs) _ _ ->
+          case mapM unwrapStringXObj xobjs of
+            Left err -> evalError ctx err (xobjInfo filePaths)
+            Right okPaths ->
+              let globalBinders = map (getGlobalBindersForDocumentation globalEnv) okPaths
+                  fauxModules = zipWith createFauxModule okPaths globalBinders
+               in (ctx, Right fauxModules)
+        x ->
+          evalError ctx ("Invalid second arg to save-docs-internal (expected array of strings containing filenames): " ++ pretty x) (xobjInfo filePaths)
+
+    createFauxModule :: String -> Map.Map String Binder -> (SymPath, Binder)
+    createFauxModule filename binders =
+      let moduleName = "Globals in " ++ filename
+          fauxGlobalModule = E.new Nothing (Just moduleName)
+          fauxGlobalModuleWithBindings = fauxGlobalModule {envBindings = binders}
+          fauxTypeEnv = E.new Nothing Nothing
+       in (SymPath [] moduleName, Binder emptyMeta (XObj (Mod fauxGlobalModuleWithBindings fauxTypeEnv) Nothing Nothing))
+
+    getEnvironmentBinderForDocumentation :: Env -> SymPath -> Either String Binder
+    getEnvironmentBinderForDocumentation env path =
       case E.searchValueBinder env path of
         Right foundBinder@(Binder _ (XObj (Mod _ _) _ _)) ->
           Right foundBinder
@@ -760,6 +796,13 @@ commandSaveDocsInternal ctx modulePath = do
         Left _ ->
           Left ("I can’t find the module `" ++ show path ++ "`")
 
+    getGlobalBindersForDocumentation :: Env -> String -> Map.Map String Binder
+    getGlobalBindersForDocumentation env filename =
+      Map.filter (\bind -> (binderFilename bind) == filename) (envBindings env)
+
+    binderFilename :: Binder -> String
+    binderFilename = takeFileName . fromMaybe "" . fmap infoFile . xobjInfo . binderXObj
+
 -- | Command for emitting literal C code from Carp.
 -- The string passed to this function will be emitted as is.
 -- This is necessary in some C interop contexts, e.g. calling macros that only accept string literals:

src/StartingEnv.hs

@@ -258,7 +258,6 @@ dynamicModule =
             f "expand" commandExpand "expands a macro and prints the result." "(expand '(when true 1)) ; => (if true 1 ())",
             f "system-include" commandAddSystemInclude "adds a system include, i.e. a C `#include` with angle brackets (`<>`)." "(system-include \"stdint.h\")",
             f "relative-include" commandAddRelativeInclude "adds a relative include, i.e. a C `include` with quotes. It also prepends the current directory." "(relative-include \"myheader.h\")",
-            f "save-docs-internal" commandSaveDocsInternal "is the internal companion command to `save-docs`. `save-docs` should be called instead." "(save-docs-internal 'Module)",
             f "read-file" commandReadFile "reads a file into a string." "(read-file \"myfile.txt\")",
             f "get-env" commandGetEnv "gets an environment variable. The result will be `()` if it isn’t set." "(read-file \"CARP_DIR\")",
             f "hash" commandHash "calculates the hash associated with a value." "(hash '('my 'value)) ; => 3175346968842793108",
@@ -278,7 +277,8 @@ dynamicModule =
             f "/" commandDiv "divides its first argument by its second." "(/ 4 2) ; => 2",
             f "*" commandMul "multiplies its two arguments." "(* 2 3) ; => 6",
             f "write-file" commandWriteFile "writes a string to a file." "(write-file \"myfile\" \"hello there!\")",
-            f "set-env" commandSetEnv "sets an environment variable." "(set-env \"CARP_WAS_HERE\" \"true\")"
+            f "set-env" commandSetEnv "sets an environment variable." "(set-env \"CARP_WAS_HERE\" \"true\")",
+            f "save-docs-ex" commandSaveDocsEx "takes two arrays, one with paths to modules (as symbols), and one with filenames (as strings). The filenames are used to emit global symbols in those files into a 'Global' module." "(save-docs-internal '(ModuleA ModuleB) '(\"globals.carp\"))"
           ]
     variadics =
       let f = addVariadicCommand . spath