RenderDocs.hs

CarpHask.cabal

@@ -39,7 +39,8 @@ library
                        Lookup,
                        Qualify,
                        Repl,
-                       StartingEnv
+                       StartingEnv,
+                       RenderDocs
 
   build-depends:       base >= 4.7 && < 5
                      , parsec == 3.1.*
@@ -50,6 +51,8 @@ library
                      , filepath
                      , split
                      , haskeline
+                     , lucid
+                     , text
 
   default-language:    Haskell2010
 

src/Commands.hs

@@ -9,6 +9,9 @@ import Deftype
 import ColorText
 import Template
 import Util
+import Lookup
+import RenderDocs
+
 import System.Directory
 import System.Info (os)
 import Control.Monad.State
@@ -669,3 +672,20 @@ commandNot [x] =
       else return (Right trueXObj)
     _ ->
       return (Left (EvalError ("Can't perform logical operation (not) on " ++ pretty x)))
+
+commandSaveDocs :: CommandCallback
+commandSaveDocs [modulePath, saveDir] =
+  case (modulePath, saveDir) of
+    (XObj (Sym path _) _ _, XObj (Str saveDirStr) _ _) ->
+      do ctx <- get
+         let globalEnv = contextGlobalEnv ctx
+         case lookupInEnv path globalEnv of
+           Just (_, Binder _ (XObj (Mod foundEnv) _ _)) ->
+             do liftIO (saveDocsForEnv foundEnv saveDirStr)
+                return dynamicNil
+           Just (_, Binder _ x) ->
+             return (Left (EvalError ("Non module can't be saved: " ++ pretty x)))
+           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)))

src/RenderDocs.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RenderDocs where
+
+import Lucid
+import Data.Text.Lazy as T
+import Data.Text.Lazy.Encoding as E
+import System.Directory
+import Debug.Trace
+
+import Obj
+import Types
+import Util
+
+saveDocsForEnv :: Env -> FilePath -> IO ()
+saveDocsForEnv env dirPath =
+  do let text = renderText (p_ "Woot?")
+         string = T.unpack text
+         name = case envModuleName env of
+                  Just hasName -> hasName
+                  Nothing -> "global"
+         fullPath = dirPath ++ "/" ++ name ++ ".html"
+     createDirectoryIfMissing False dirPath
+     writeFile fullPath string