Pretty nice looking docs.

core/Macros.carp

@@ -273,3 +273,7 @@
         (list 'Dynamic.String.join [(list 'Dynamic.String.directory (list 'source-path))
                                     "/"
                                     file])))
+
+(defmacro save-docs [module dir-path]
+  ;; A trick to be able to send unquoted symbols to 'save-docs'
+  (list 'save-docs-internal (list 'quote module) dir-path))

core/Pattern.carp

@@ -33,6 +33,7 @@
   (defn num? [s]
     (Pattern.matches? #"^[0-9]*$" s))
 
+  (doc alpha? "Check if a string contains only alpha characters (a-Z).")
   (defn alpha? [s]
     (Pattern.matches? #"^[\u\l]*$" s))
 

docs/core/carp_style.css

@@ -0,0 +1,50 @@
+html {
+    font-family: "Helvetica", sans-serif;
+}
+
+a {
+    color: #ff0000;
+}
+
+.logo {
+    text-align: center;
+    float: right;
+    width: 150px;
+    font-family: "Hasklig", "Lucida Console", monospace;
+}
+
+.logo img {
+    width: 150px;
+}
+
+.content {
+    margin: 3em auto auto auto;
+    width: 80%;
+}
+
+h1 {
+    margin-bottom: 1.5em;
+}
+
+h3 {
+    margin: 0em;
+}
+
+.binder {
+    margin: 0em 0em 3.5em 0em;
+}
+
+.sig {
+    font-family: "Hasklig", "Lucida Console", monospace;
+}
+
+.doc {
+    /* font-style: italic; */
+    color: #456;
+}
+
+.description {
+    margin-top: 0.3em;
+    font-size: 0.8em;
+    color: #aaa;
+}

examples/temp.carp

@@ -11,3 +11,5 @@
   (defn g [] 10000))
 
 (doc Foo.g "The 10000 dollar function, annotated from afar.")
+
+(save-docs String "docs/core/")

src/Commands.hs

@@ -673,8 +673,8 @@ commandNot [x] =
     _ ->
       return (Left (EvalError ("Can't perform logical operation (not) on " ++ pretty x)))
 
-commandSaveDocs :: CommandCallback
-commandSaveDocs [modulePath, saveDir] =
+commandSaveDocsInternal :: CommandCallback
+commandSaveDocsInternal [modulePath, saveDir] =
   case (modulePath, saveDir) of
     (XObj (Sym path _) _ _, XObj (Str saveDirStr) _ _) ->
       do ctx <- get
@@ -688,4 +688,4 @@ commandSaveDocs [modulePath, saveDir] =
            Nothing ->
              return (Left (EvalError ("Can't find module at '" ++ show path ++ "'")))
     (arg1, arg2) ->
-      return (Left (EvalError ("Invalid args to save-docs " ++ pretty arg1 ++ ", " ++ pretty arg2)))
+      return (Left (EvalError ("Invalid args to save-docs (expected symbol and string): " ++ pretty arg1 ++ ", " ++ pretty arg2)))

src/RenderDocs.hs

@@ -5,7 +5,9 @@ module RenderDocs where
 import Lucid
 import Data.Text.Lazy as T
 import Data.Text.Lazy.Encoding as E
+import Data.Text as Text
 import System.Directory
+import qualified Data.Map as Map
 import Debug.Trace
 
 import Obj
@@ -14,11 +16,44 @@ import Util
 
 saveDocsForEnv :: Env -> FilePath -> IO ()
 saveDocsForEnv env dirPath =
-  do let text = renderText (p_ "Woot?")
-         string = T.unpack text
+  do let string = T.unpack text
          name = case envModuleName env of
                   Just hasName -> hasName
                   Nothing -> "global"
          fullPath = dirPath ++ "/" ++ name ++ ".html"
+         text = renderText (envToHtml env name)
      createDirectoryIfMissing False dirPath
      writeFile fullPath string
+
+envToHtml :: Env -> String -> Html ()
+envToHtml env name =
+   html_ $ do head_ $
+                do meta_ [charset_ "UTF-8"]
+                   link_ [rel_ "stylesheet", href_ "carp_style.css"]
+              body_ $
+                do div_ [class_ "content"] $
+                     do div_ [class_ "logo"] $
+                          do a_ [href_ "http://github.com/carp-lang/Carp"] $
+                               do img_ [src_ "logo2.png"]
+                             span_ "CARP DOCS"
+                        h1_ (toHtml name)
+                        mapM_ (binderToHtml . snd) (Map.toList (envBindings env))
+
+binderToHtml :: Binder -> Html ()
+binderToHtml (Binder meta xobj) =
+  let SymPath _ name = getPath xobj
+      description = getBinderDescription xobj
+      typeSignature = case ty xobj of
+                 Just t -> show t
+                 Nothing -> ""
+      metaMap = getMeta meta
+      docString = case Map.lookup "doc" metaMap of
+                    Just (XObj (Str s) _ _) -> s
+                    Just found -> pretty found
+                    Nothing -> ""
+  in  do div_ [class_ "binder"] $
+           do h3_ [id_ (Text.pack name)] (toHtml name)
+              div_ [class_ "description"] (toHtml description)
+              p_ [class_ "sig"] (toHtml typeSignature)
+              p_ [class_ "doc"] (toHtml docString)
+              --p_ (toHtml (description))

src/StartingEnv.hs

@@ -190,6 +190,7 @@ dynamicModule = Env { envBindings = bindings, envParent = Nothing, envModuleName
                     , addCommand "os" 0 commandOS
                     , addCommand "system-include" 1 commandAddSystemInclude
                     , addCommand "local-include" 1 commandAddLocalInclude
+                    , addCommand "save-docs-internal" 2 commandSaveDocsInternal
                     ]
                     ++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
                        ,("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing))