husk-scheme 2.2 → 2.3

raw patch · 6 files changed

+202/−51 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.markdown +6/−8
• hs-src/Language/Scheme/Core.hs +140/−28
• hs-src/Language/Scheme/Types.hs +16/−9
• hs-src/shell.hs +10/−3
• husk-scheme.cabal +1/−1
• stdlib.scm +29/−2

@@ -23,9 +23,9 @@ - Basic IO functions - Standard library of Scheme functions - Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline to provide a rich user experience-- <b>Full numeric tower</b>: includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types and other constraints from the R<sup>5</sup>RS specification.-- <b>Continuations</b>: call/cc and first-class continuations.-- <b>Hygienic Macros</b>: High-level macros via define-syntax - *Note this is still somewhat of a work in progress* and while it works well enough that many derived forms are implemented in our standard library, you may still run into problems when defining your own macros.+- Full numeric tower: includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types and other constraints from the R<sup>5</sup>RS specification.+- Continuations: call/cc and first-class continuations.+- Hygienic Macros: High-level macros via define-syntax - *Note this is still somewhat of a work in progress* and while it works well enough that many derived forms are implemented in our standard library, you may still run into problems when defining your own macros.  As well as the following approved extensions: @@ -55,8 +55,8 @@  A Haskell API is also provided to allow you to embed a Scheme interpreter within a Haskell program. The key API modules are: -- Language.Scheme.Core - Contains functions to evaluate (execute) Scheme code.-- Language.Scheme.Types - Contains Haskell data types used to represent Scheme primitives.+- `Language.Scheme.Core` - Contains functions to evaluate (execute) Scheme code.+- `Language.Scheme.Types` - Contains Haskell data types used to represent Scheme primitives.  For more information, run `make doc` to generate API documentation from the source code. Also, see `shell.hs` for a quick example of how you might get started. @@ -67,9 +67,7 @@  - [GHC](http://www.haskell.org/ghc/) - Or at the very least, no other compiler has been tested. - [cabal-install](http://hackage.haskell.org/trac/hackage/wiki/CabalInstall) may be used to build, deploy, and generate packages for husk.-- Haskeline - which may be installed using cabal:--    cabal install haskeline+- Haskeline - which may be installed using cabal: `cabal install haskeline`  The `scm-unit-tests` directory contains unit tests for much of the scheme code. All tests may be executed via `make test` command. 

@@ -71,14 +71,11 @@  - return a result.  - -} continueEval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal+ -- Passing a higher-order function as the continuation; just evaluate it. This is  -- done to enable an 'eval' function to be broken up into multiple sub-functions, -- so that any of the sub-functions can be passed around as a continuation.------ This perhaps shows cruft as we also pass cBody (scheme code) as a continuation.--- We could probably just use higher-order functions instead, but both are used for--- two different things.-continueEval _ (Continuation cEnv _ cCont funcArgs (Just func)) val = func cEnv cCont val funcArgs+continueEval _ (Continuation cEnv (Just (HaskellBody func funcArgs)) (Just cCont) _) val = func cEnv cCont val funcArgs  -- No higher order function, so: --@@ -88,14 +85,20 @@ -- continuation (if there is one), or we just return the result. Yes technically with -- CPS you are supposed to keep calling into functions and never return, but eventually -- when the computation is complete, you have to return something.-continueEval _ (Continuation cEnv cBody cCont Nothing Nothing) val = do+continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) _) val = do     case cBody of         [] -> do           case cCont of-            Continuation nEnv _ _ _ _ -> continueEval nEnv cCont val+            Continuation nEnv _ _ _ -> continueEval nEnv cCont val             _ -> return (val)-        [lv] -> eval cEnv (Continuation cEnv [] cCont Nothing Nothing) (lv)-        (lv : lvs) -> eval cEnv (Continuation cEnv lvs cCont Nothing Nothing) (lv)+        [lv] -> eval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) False) (lv)+        (lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) False) (lv)++-- No current continuation, but a next cont is available; call into it+continueEval _ (Continuation cEnv Nothing (Just cCont) _) val = continueEval cEnv cCont val++-- There is no continuation code, just return value+continueEval _ (Continuation _ Nothing Nothing _) val = return val continueEval _ _ _ = throwError $ Default "Internal error in continueEval"  -- |Core eval function@@ -132,6 +135,23 @@ eval env cont val@(HashTable _) = continueEval env cont val eval env cont val@(Vector _)    = continueEval env cont val eval env cont (Atom a)          = continueEval env cont =<< getVar env a++-- Evaluate an expression in the current environment+--+-- Calls into eval once to get raw expression, and a second time+-- to eval *that* expression.+--+-- Assumption is any macro transform is already performed+-- prior to this step.+--+-- FUTURE: consider allowing env to be specified, per R5RS+--+eval env cont (List [Atom "eval", val]) = do+  eval env (makeCPS env cont cps) val+  where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+        cps e c result _ = eval e c result++-- Quote an expression by simply passing along the value eval env cont (List [Atom "quote", val])         = continueEval env cont val  -- Unquote an expression; unquoting is different than quoting in that@@ -235,7 +255,7 @@           cpsResult e c result _ =              case result of               Bool True -> eval e c conseq-              _ -> continueEval e c $ Atom "#unspecified" -- Unspecified return value per R5RS+              _ -> continueEval e c $ Nil "" -- Unspecified return value per R5RS  -- FUTURE: convert cond to a derived form (scheme macro) eval env cont (List (Atom "cond" : clauses)) = @@ -248,7 +268,7 @@          List (cond : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) cond          badType -> throwError $ TypeMismatch "clause" badType    where-        -- If a condition is true, evalue that condition's expressions.+        -- If a condition is true, evaluate that condition's expressions.         -- Otherwise just pick up at the next condition...         cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal         cpsResult e cnt result (Just (c:cs)) = @@ -485,6 +505,23 @@ -- -- +eval env cont (List [Atom "call-with-values", producer, consumer]) = do+-- TODO: validate that producer and consumer are functions+  eval env+  -- TODO: problem is that this continuation will not be called into by (values), rather+  --       one of the conts inside producer will be called instead...+      (Continuation env (Just (HaskellBody cpsEval Nothing)) (Just cont) True) -- Multiple Values+      (List [producer]) -- Call into prod to get values+ where+   cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+   cpsEval e c (List values) _ = do+        -- should handle if multiple values are passed...+        eval e c $ List $ [consumer] ++ values --List [consumer , value]+-- should not need the following case??+   cpsEval e c value _ = eval e c $ List [consumer, value]+    --throwError $ Default $ "Unexpected error in call-with-values, value = " ++ show value+eval _ _ (List (Atom "call-with-values" : _)) = throwError $ Default "Procedures not specified"+ eval env cont (List (Atom "call-with-current-continuation" : args)) =    eval env cont (List (Atom "call/cc" : args)) eval _ _ (List [Atom "call/cc"]) = throwError $ Default "Procedure not specified"@@ -496,7 +533,7 @@         PrimitiveFunc f -> do             result <- liftThrows $ f [cont]             case cont of -                Continuation cEnv _ _ _ _ -> continueEval cEnv cont result+                Continuation cEnv _ _ _ -> continueEval cEnv cont result                 _ -> return result         Func aparams _ _ _ ->           if (toInteger $ length aparams) == 1 @@ -551,19 +588,31 @@  -- Call into a Scheme function apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal-apply _ c@(Continuation env _ _ _ _) args = do-  if (toInteger $ length args) /= 1 -    then throwError $ NumArgs 1 args-    else continueEval env c $ head args+apply _ c@(Continuation env _ _ multipleValues) args = do+  if multipleValues+    then continueEval env c $ List args+    else+      if (toInteger $ length args) /= 1 +        then throwError $ NumArgs 1 args+        else continueEval env c $ head args++-- TODO: Think about wrapping the result into a new LispVal "multipleValues" that+-- will be returned in len(args) > 1. this var would then only be used by the call-with-values+-- continuation. otherwise it would eventually throw an error... is that feasible?++{-        -- Hack: just pass all of the args along.+        -- Assumption is that a multi-value continuation will eventually appear to accept this.+        -- Really need a better solution, because this breaks other cont code...+        continueEval env c $ List args -- TODO - testing: head args -} apply cont (IOFunc func) args = do   result <- func args   case cont of-    Continuation cEnv _ _ _ _ -> continueEval cEnv cont result+    Continuation cEnv _ _ _ -> continueEval cEnv cont result     _ -> return result apply cont (PrimitiveFunc func) args = do   result <- liftThrows $ func args   case cont of-    Continuation cEnv _ _ _ _ -> continueEval cEnv cont result+    Continuation cEnv _  _ _ -> continueEval cEnv cont result     _ -> return result apply cont (Func aparams avarargs abody aclosure) args =   if num aparams /= num args && avarargs == Nothing@@ -584,14 +633,14 @@         -- See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294         --         evalBody evBody env = case cont of-            Continuation _ cBody cCont _ Nothing -> if length cBody == 0+            Continuation _ (Just (SchemeBody cBody)) (Just cCont) _ -> if length cBody == 0                 then continueWCont env (evBody) cCont                 else continueWCont env (evBody) cont -- Might be a problem, not fully optimizing             _ -> continueWCont env (evBody) cont          -- Shortcut for calling continueEval         continueWCont cwcEnv cwcBody cwcCont = -            continueEval cwcEnv (Continuation cwcEnv cwcBody cwcCont Nothing Nothing) $ Nil ""+            continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) False) $ Nil ""          bindVarArgs arg env = case arg of           Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)]@@ -611,8 +660,29 @@                 ("open-output-file", makePort WriteMode),                 ("close-input-port", closePort),                 ("close-output-port", closePort),+                ("input-port?", isInputPort),+                ("output-port?", isOutputPort),++               -- The following optional procedures are NOT implemented:+               -- +               --  with-input-from-file+               --  with-output-from-file+               --  transcript-on+               --  transcript-off+               --+               --  Consideration may be given in a future release, but keep in mind+               --  the impact to the other I/O functions.++-- TODO: not currently supported: char-ready?++                ("current-input-port", currentInputPort),+                ("current-output-port", currentOutputPort),                 ("read", readProc),-                ("write", writeProc),+                ("read-char", readCharProc hGetChar),+                ("peek-char", readCharProc hLookAhead),+                ("write", writeProc (\port obj -> hPrint port obj)),+                ("write-char", writeCharProc),+                ("display", writeProc (\port obj -> hPutStr port $ show obj)),                 ("read-contents", readContents),                 ("read-all", readAll)] @@ -625,6 +695,21 @@ closePort [Port port] = liftIO $ hClose port >> (return $ Bool True) closePort _ = return $ Bool False +currentInputPort, currentOutputPort :: [LispVal] -> IOThrowsError LispVal+-- FUTURE: For now, these are just hardcoded to the standard i/o ports.+--         a future implementation that includes with-*put-from-file+--         would require a more involved implementation here as well as+--         other I/O functions hooking into these instead of std*+currentInputPort _ = return $ Port stdin+currentOutputPort _ = return $ Port stdout++isInputPort, isOutputPort :: [LispVal] -> IOThrowsError LispVal+isInputPort [Port port] = liftM Bool $ liftIO $ hIsReadable port+isInputPort _ = return $ Bool False++isOutputPort [Port port] = liftM Bool $ liftIO $ hIsWritable port+isOutputPort _ = return $ Bool False+ readProc :: [LispVal] -> IOThrowsError LispVal readProc [] = readProc [Port stdin] readProc [Port port] = do@@ -637,17 +722,44 @@             liftThrows $ readExpr inpStr  readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args -writeProc :: [LispVal] -> IOThrowsError LispVal-writeProc [obj] = writeProc [obj, Port stdout]-writeProc [obj, Port port] = do-    output <- liftIO $ try (liftIO $ hPrint port obj)+readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal+readCharProc func [] = readCharProc func [Port stdin]+readCharProc func [Port port] = do+    liftIO $ hSetBuffering port NoBuffering+    input <-  liftIO $ try (liftIO $ func port)+    liftIO $ hSetBuffering port LineBuffering+    case input of+        Left e -> if isEOFError e+                     then return $ EOF+                     else throwError $ Default "I/O error reading from port"+        Right inpChr -> do +            return $ Char inpChr +readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args++{-writeProc :: --forall a (m :: * -> *).+             (MonadIO m, MonadError LispError m) =>+             (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -}+writeProc func [obj] = writeProc func [obj, Port stdout]+writeProc func [obj, Port port] = do+    output <- liftIO $ try (liftIO $ func port obj)     case output of-        Left e -> throwError $ Default "I/O error writing to port"+        Left _ -> throwError $ Default "I/O error writing to port"         Right _ -> return $ Nil ""-writeProc other = if length other == 2+writeProc _ other = if length other == 2                      then throwError $ TypeMismatch "(value port)" $ List other                       else throwError $ NumArgs 2 other +writeCharProc :: [LispVal] -> IOThrowsError LispVal+writeCharProc [obj] = writeCharProc [obj, Port stdout]+writeCharProc [obj@(Char _), Port port] = do+    output <- liftIO $ try (liftIO $ (hPutStr port $ show obj))+    case output of+        Left _ -> throwError $ Default "I/O error writing to port"+        Right _ -> return $ Nil ""+writeCharProc other = if length other == 2+                     then throwError $ TypeMismatch "(character port)" $ List other +                     else throwError $ NumArgs 2 other+ readContents :: [LispVal] -> IOThrowsError LispVal readContents [String filename] = liftM String $ liftIO $ readFile filename readContents [] = throwError $ NumArgs 1 []@@ -1047,7 +1159,7 @@ isDottedList _ = return $  Bool False  isProcedure :: [LispVal] -> ThrowsError LispVal-isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True+isProcedure ([Continuation _ _ _ _]) = return $ Bool True isProcedure ([PrimitiveFunc _]) = return $ Bool True isProcedure ([Func _ _ _ _]) = return $ Bool True isProcedure ([IOFunc _]) = return $ Bool True

@@ -133,11 +133,10 @@          -- ^ 	| Port Handle          -- ^I/O port-	| Continuation {  closure :: Env    -- Environment of the continuation-                        , body :: [LispVal] -- Code in the body of the continuation-                        , continuation :: LispVal    -- Code to resume after body of cont-                        , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to a higher-order function -                        , continuationFunction :: (Maybe (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal))+	| Continuation {  closure :: Env                     -- Environment of the continuation+                        , currentCont :: (Maybe DeferredCode)-- Code of current continuation+                        , nextCont    :: (Maybe LispVal)     -- Code to resume after body of cont+                        , multipleArgs :: Bool                         -- FUTURE: stack (for dynamic wind)                        }          -- ^Continuation@@ -145,17 +144,25 @@  	| Nil String          -- ^Internal use only; do not use this type directly. +-- |Container to hold code that is passed to a continuation for deferred execution +data DeferredCode = +    SchemeBody [LispVal] | -- ^A block of Scheme code+    HaskellBody {  +       contFunction :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)+     , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to the higher-order function +    } -- ^A Haskell function+ -- Make an "empty" continuation that does not contain any code makeNullContinuation :: Env -> LispVal-makeNullContinuation env = Continuation env [] (Nil "") Nothing Nothing +makeNullContinuation env = Continuation env Nothing Nothing False  -- Make a continuation that takes a higher-order function (written in Haskell) makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal]-> IOThrowsError LispVal) -> LispVal-makeCPS env cont cps = Continuation env [] cont Nothing (Just cps)+makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) False  -- Make a continuation that stores a higher-order function and arguments to that function makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal-makeCPSWArgs env cont cps args = Continuation env [] cont (Just args) (Just cps)+makeCPSWArgs env cont cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) False  instance Ord LispVal where   compare (Bool a) (Bool b) = compare a b@@ -230,7 +237,7 @@ showVal (List contents) = "(" ++ unwordsList contents ++ ")" showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" showVal (PrimitiveFunc _) = "<primitive>"-showVal (Continuation {closure = _, body = _}) = "<continuation>"+showVal (Continuation _ _ _ _) = "<continuation>" showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =    "(lambda (" ++ unwords (map show args) ++     (case varargs of

@@ -32,9 +32,16 @@  runOne :: [String] -> IO () runOne args = do+  -- Use this to suppress unwanted output.+  -- Makes this unix-specific, but as of now+  -- everything else is anyway, so...+  nullIO <- openFile "/dev/null" WriteMode++  stdlib <- getDataFileName "stdlib.scm"   env <- primitiveBindings >>= flip extendEnv [((varNamespace, "args"), List $ map String $ drop 1 args)]+  evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library   (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)]))-     >>= hPutStrLn stderr  -- echo this or not??+     >>= hPutStrLn nullIO    -- Call into (main) if it exists...   alreadyDefined <- liftIO $ isBound env "main"@@ -52,8 +59,8 @@   putStrLn " | | | | |_| \\__ \\   <    /// \\\\\\   \\__ \\ (__| | | |  __/ | | | | |  __/ "   putStrLn " |_| |_|\\__,_|___/_|\\_\\  ///   \\\\\\  |___/\\___|_| |_|\\___|_| |_| |_|\\___| "   putStrLn "                                                                         "-  putStrLn " husk Scheme Interpreter                                     Version 2.2 "-  putStrLn " (c) 2010 Justin Ethier              github.com/justinethier/husk-scheme "+  putStrLn " husk Scheme Interpreter                                     Version 2.3 "+  putStrLn " (c) 2010-2011 Justin Ethier         github.com/justinethier/husk-scheme "   putStrLn "                                                                         "  runRepl :: IO ()

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             2.2+Version:             2.3 Synopsis:            R5RS Scheme interpreter program and library. Description:         Husk is a dialect of Scheme written in Haskell that implements                       a subset of the R5RS standard. Advanced R5RS features are

@@ -218,7 +218,35 @@                          (set! result-ready? #t)                          result)))))))) -; Hash table derived forms+; End delayed evaluation section++; Continuation Section+(define (values . things)+    (call-with-current-continuation +        (lambda (cont) (apply cont things))))++;; I/O Section+(define (newline . port)+  (if (null? port) +      (display #\newline) +      (display #\newline port)))++; TODO: test these forms+(define (call-with-input-file filename proc)+  (let ((opened-file (open-input-file filename)))+    (define result+           (proc opened-file))+    (close-input-port opened-file)+    result))+; TODO: test+(define (call-with-output-file filename proc)+  (let ((opened-file (open-output-file filename)))+    (define result+           (proc opened-file))+    (close-output-port opened-file)+    result))++;; Hashtable derived forms (define hash-table-walk   (lambda (ht proc)     (map @@ -249,7 +277,6 @@ ;(define (hash-table-fold hash-table f init-value) ;    TBD) -; End delayed evaluation section  ; FUTURE: Issue #10: from numeric section - ; gcd