husk-scheme 3.8 → 3.9

raw patch · 7 files changed

+57/−35 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.markdown +7/−0
• hs-src/Compiler/huskc.hs +14/−11
• hs-src/Language/Scheme/Compiler.hs +31/−19
• hs-src/Language/Scheme/Core.hs +1/−1
• hs-src/Language/Scheme/FFI.hs +1/−1
• hs-src/Language/Scheme/Types.hs +2/−2
• husk-scheme.cabal +1/−1

@@ -1,3 +1,10 @@+v3.9+--------++- Fixed a syntax error that prevented the FFI module from building. Thanks to Ricardo Lanziano for bringing this to my attention!+- Enhanced the compiler to use the name of the source file for the compiled Haskell output instead of hardcoding the file to `_tmp.hs`. For example, `my-file.scm` will compile to `my-file.hs`.+- Removed extraneous quotes when printing a lambda form.+ v3.8 -------- 

@@ -44,13 +44,14 @@      then showUsage      else do         let inFile = nonOpts !! 0+            outHaskell = (dropExtension inFile) ++ ".hs"             outExec = case output of               Just inFile -> inFile               Nothing -> dropExtension inFile             extraOpts = case extra of               Just args -> args               Nothing -> ""-        process inFile outExec dynamic extraOpts+        process inFile outHaskell outExec dynamic extraOpts  --  -- For an explanation of the command line options code, see:@@ -128,8 +129,8 @@   exitWith ExitSuccess  -- |High level code to compile the given file-process :: String -> String -> Bool -> String -> IO ()-process inFile outExec dynamic extraArgs = do+process :: String -> String -> String -> Bool -> String -> IO ()+process inFile outHaskell outExec dynamic extraArgs = do   -- TODO: how to integrate r5rsEnv and libraries?@@ -138,14 +139,14 @@   env <- Language.Scheme.Core.primitiveBindings   stdlib <- getDataFileName "lib/stdlib.scm"   srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension)-  result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlib srfi55 inFile)+  result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlib srfi55 inFile outHaskell)   case result of    Just errMsg -> putStrLn errMsg-   _ -> compileHaskellFile outExec dynamic extraArgs+   _ -> compileHaskellFile outHaskell outExec dynamic extraArgs  -- |Compile a scheme file to haskell-compileSchemeFile :: Env -> String -> String -> String -> IOThrowsError LispVal-compileSchemeFile env stdlib srfi55 filename = do+compileSchemeFile :: Env -> String -> String -> String -> String -> IOThrowsError LispVal+compileSchemeFile env stdlib srfi55 filename outHaskell = do   let conv :: LispVal -> String       conv (String s) = s   -- TODO: it is only temporary to compile the standard library each time. It should be @@ -162,13 +163,15 @@   List imports <- getNamespacedVar env 't' {-"internal"-} "imports"   let moreHeaderImports = map conv imports -  outH <- liftIO $ openFile "_tmp.hs" WriteMode+  outH <- liftIO $ openFile outHaskell WriteMode   _ <- liftIO $ writeList outH headerModule   _ <- liftIO $ writeList outH $ map (\mod -> "import " ++ mod ++ " ") $ headerImports ++ moreHeaderImports   filepath <- liftIO $ getDataFileName ""   _ <- liftIO $ writeList outH $ header filepath   _ <- liftIO $ writeList outH $ map show libsC+  _ <- liftIO $ hPutStrLn outH " ------ END OF STDLIB ------"   _ <- liftIO $ writeList outH $ map show libSrfi55C+  _ <- liftIO $ hPutStrLn outH " ------ END OF SRFI 55 ------"   _ <- liftIO $ writeList outH $ map show execC   _ <- liftIO $ hClose outH   if not (null execC)@@ -176,11 +179,11 @@      else throwError $ Default "Empty file" --putStrLn "empty file"  -- |Compile the intermediate haskell file using GHC-compileHaskellFile :: String -> Bool -> String -> IO() --ThrowsError LispVal-compileHaskellFile filename dynamic extraArgs = do+compileHaskellFile :: String -> String -> Bool -> String -> IO() --ThrowsError LispVal+compileHaskellFile hsInFile objOutFile dynamic extraArgs = do   let ghc = "ghc" -- Need to make configurable??       dynamicArg = if dynamic then "-dynamic" else ""-  compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -o " ++ filename ++ " _tmp.hs"+  compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -o " ++ objOutFile ++ " " ++ hsInFile  -- TODO: delete intermediate hs files if requested 

@@ -683,27 +683,37 @@  return $ [entryPt, compiledUpdate] ++ compiledIdx -- TODO: eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do --- TODO:--- Testing this out; idea is to compile-in any code injected via load++compile env (List (Atom "%import" : args)) copts = do+    throwError $ NotImplemented $ "%import, with args: " ++ show args+ compile env (List [Atom "load", filename, envSpec]) copts = do-  -- More TODO:-  -- Hacking around, the issue with require-extension / and-let* is that-  -- the compiler loads (and-let*) and attempts to compile the argument-  -- () which cannot be evaluated, hence the special form error on ()-  ---  -- LispEnv env-  y <- Language.Scheme.Core.evalLisp env envSpec-  -- TODO: I think this is no good because current-environment is really the-  -- same as env here. it would need to be evaluated and stored when it is first found-  -- hmm...not quite sure how to proceed here, need to think on it-  LispEnv env' <- Language.Scheme.Core.evalLisp env y-  compile env' (List [Atom "load", filename]) copts-compile env (List [Atom "load", Atom filename]) copts = do-  String filename' <- getVar env filename-  compile env (List [Atom "load", String filename']) copts-compile env (List [Atom "load", String filename]) copts = do -- TODO: allow filename from a var, support env optional arg++  -- F*ck it, just run the evaluator here since filename is req'd at compile time+ -- TODO: error handling for string below+  String filename' <- Language.Scheme.Core.evalLisp env filename++  Atom symEnv <- _gensym "loadEnv"+  Atom symLoad <- _gensym "load"+  compEnv <- compileExpr env envSpec symEnv+                         Nothing -- Return env to our custom func+  compLoad <- compileLisp env filename' symLoad Nothing+ +  -- Entry point+  f <- return $ [+    -- TODO: should do runtime error checking if something else+    --       besides a LispEnv is returned+    AstValue $ "  LispEnv e <- " ++ symEnv ++ " env (makeNullContinuation env) (Nil \"\") [] ",+    AstValue $ "  result <- " ++ symLoad ++ " e (makeNullContinuation e) (Nil \"\") Nothing",+    createAstCont copts "result" ""]+  -- Join compiled code together+  return $ [createAstFunc copts f] ++ compEnv ++ compLoad++compile env (List [Atom "load", filename]) copts = do -- TODO: allow filename from a var, support env optional arg+ -- TODO: error handling for string below+ String filename' <- Language.Scheme.Core.evalLisp env filename  Atom symEntryPt <- _gensym "load"- result <- compileLisp env filename symEntryPt Nothing+ result <- compileLisp env filename' symEntryPt Nothing  return $ result ++     [createAstFunc copts [     AstValue $ "  result <- " ++ symEntryPt ++ " env (makeNullContinuation env) (Nil \"\") Nothing",@@ -862,3 +872,5 @@         rest <- compileArgs nextFunc True as -- True indicates nextFunc needs to use value arg passed into it         return $ [ f, c] ++ _comp ++ rest +compileApply _ err _ = do+    throwError $ Default $ "compileApply - Unexpected argument: " ++ show err

@@ -60,7 +60,7 @@  -- |husk version number version :: String-version = "3.8"+version = "3.9"  -- |A utility function to display the husk console banner showBanner :: IO ()

@@ -112,7 +112,7 @@     return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)   defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont -evalfuncLoadFFI _ = throwError $ NumArgs 3 []+evalfuncLoadFFI _ = throwError $ NumArgs (Just 3) []  defaultRunGhc :: GHC.Ghc a -> IO a defaultRunGhc =

@@ -442,12 +442,12 @@ showVal (Syntax _ _ _ _ _) = "<syntax>" showVal (SyntaxExplicitRenaming _) = "<er-macro-transformer syntax>" showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =-  "(lambda (" ++ unwords (map show args) +++  "(lambda (" ++ unwords args ++     (case varargs of       Nothing -> ""       Just arg -> " . " ++ arg) ++ ") ...)" showVal (HFunc {hparams = args, hvararg = varargs, hbody = _, hclosure = _}) =-  "(lambda (" ++ unwords (map show args) +++  "(lambda (" ++ unwords args ++     (case varargs of       Nothing -> ""       Just arg -> " . " ++ arg) ++ ") ...)"

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             3.8+Version:             3.9 Synopsis:            R5RS Scheme interpreter, compiler, and library. Description:            <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>