Merge pull request #590 from hellerve/write-file

Add write-file

docs/core/Dynamic.html

@@ -1642,6 +1642,25 @@
                 </span>
                 <p class="doc">
                     
+                </p>
+            </div>
+            <div class="binder">
+                <a class="anchor" href="#write-file">
+                    <h3 id="write-file">
+                        write-file
+                    </h3>
+                </a>
+                <div class="description">
+                    command
+                </div>
+                <p class="sig">
+                    Dynamic
+                </p>
+                <span>
+                    
+                </span>
+                <p class="doc">
+                    
                 </p>
             </div>
         </div>

src/Commands.hs

@@ -814,6 +814,22 @@ commandReadFile [filename] =
     _ ->
       return (Left (EvalError ("The argument to `read-file` must be a string, I got `" ++ pretty filename ++ "`") (info filename)))
 
+commandWriteFile :: CommandCallback
+commandWriteFile [filename, contents] =
+  case filename of
+    XObj (Str fname) _ _ -> do
+      case contents of
+        XObj (Str s) _ _ -> do
+         exceptional <- liftIO $ ((try $ writeFile fname s) :: (IO (Either IOException ())))
+         case exceptional of
+            Right () -> return dynamicNil
+            Left _ ->
+              return (Left (EvalError ("Cannot write to argument to `" ++ fname ++ "`, an argument to `write-file`") (info filename)))
+        _ ->
+          return (Left (EvalError ("The second argument to `write-file` must be a string, I got `" ++ pretty contents ++ "`") (info contents)))
+    _ ->
+      return (Left (EvalError ("The first argument to `write-file` must be a string, I got `" ++ pretty filename ++ "`") (info filename)))
+
 commandSaveDocsInternal :: CommandCallback
 commandSaveDocsInternal [modulePath] = do
      ctx <- get

src/StartingEnv.hs

@@ -244,6 +244,7 @@ dynamicModule = Env { envBindings = bindings
                     , addCommand "relative-include" 1 commandAddRelativeInclude
                     , addCommand "save-docs-internal" 1 commandSaveDocsInternal
                     , addCommand "read-file" 1 commandReadFile
+                    , addCommand "write-file" 2 commandWriteFile
                     ]
                     ++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
                        ,("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing))