haskeem-0.7.4: LispData.hs
{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>
Portions of this were derived from Jonathan Tang's haskell
tutorial "Write yourself a scheme in 48 hours" and are thus
Copyright Jonathan Tang
(but I can't easily tell anymore who originally wrote what)
This file is part of haskeem.
haskeem is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
haskeem is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with haskeem; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
$Id: lispdata.hs,v 1.14 2009-06-27 21:51:29 uwe Exp $ -}
module LispData
(LispVal(Symbol, Boolean, Char, Delay, DottedList, IntNumber,
RatNumber, FltNumber, Func, IOPrim, List, Port, Prim,
Socket, String, Vector),
LispError(NumArgs, TypeMismatch, Parser, BadSpecial, NotFunction,
UnboundVar, Default, OutOfRange, VectorBounds, UserException),
ThrowsError, Env, IOThrowsError, liftThrows,
myRatPInf, myRatNInf, myRatNaN, myFltPInf, myFltNInf, myFltNaN,
lispTrue, lispFalse) where
import Prelude
import IO hiding (try)
import Data.Char
import Data.Ratio()
import Text.ParserCombinators.Parsec as TPCP hiding (spaces)
import Control.Monad.Error as CME
import Data.IORef
import qualified Data.IntMap as DIM
import GHC.Real -- for the :% operator, which does not reduce the fractions
import Network
-- Define everything we are going to work with, and how to display it
-- rational infinities and NaN: gotta take care with these,
-- they don't always play nice with other numbers
myRatPInf, myRatNInf, myRatNaN :: Rational
myRatPInf = 1:%0
myRatNInf = (-1):%0
myRatNaN = 0:%0
-- floating-point infinities and NaN
myFltPInf, myFltNInf, myFltNaN :: Double
myFltPInf = (1.0e99 ** 1.0e99) -- probably big enough...
myFltNInf = (-myFltPInf)
myFltNaN = sqrt (-1.0)
-- An environment: a table connecting names of objects and values
type Env = IORef [(String, IORef LispVal)]
-- A lisp value: these are the stuff which normally gets processed
data LispVal = Symbol String
| Boolean Bool
| IntNumber Integer
| RatNumber Rational
| FltNumber Double
| String String
| List [LispVal]
| DottedList [LispVal] LispVal
| Char Char
| Prim ([LispVal] -> ThrowsError LispVal)
| Func {params :: [String],
vararg :: (Maybe String),
body :: [LispVal],
closure :: Env,
name :: (Maybe String),
macro :: Bool}
| Delay {obj :: LispVal,
closure :: Env,
tag :: String}
| IOPrim ([LispVal] -> IOThrowsError LispVal)
| Port Handle
| Socket Socket
| Vector Integer (DIM.IntMap LispVal)
instance Show LispVal where show = showVal
showVal :: LispVal -> String
showVal (Symbol atom) = atom
showVal (Boolean True) = "#t"
showVal (Boolean False) = "#f"
showVal (IntNumber num) = show num
showVal (RatNumber num) =
(show (numerator num)) ++ "/" ++ (show (denominator num))
showVal (FltNumber num) = show num
showVal (String str) = "\"" ++ str ++ "\""
showVal (List lst) = "(" ++ (unwords (map showVal lst)) ++ ")"
showVal (DottedList lst cab) = "(" ++ (unwords (map showVal lst))
++ " . " ++ (showVal cab) ++ ")"
-- the control-character printing and parsing assumes ASCII
showVal (Char ch) | (ch == (chr 0)) = "#\\nul"
| (ch == (chr 7)) = "#\\alarm"
| (ch == (chr 8)) = "#\\backspace"
| (ch == '\t') = "#\\tab"
| (ch == '\n') = "#\\linefeed"
| (ch == (chr 11)) = "#\\vtab"
| (ch == (chr 12)) = "#\\page"
| (ch == '\r') = "#\\return"
| (ch == (chr 27)) = "#\\esc"
| (ch == ' ') = "#\\space"
| (ch == (chr 127)) = "#\\delete"
| isControl ch = "#\\^" ++ [chr (ord ch + ord 'A' - 1)]
| isPrint ch = "#\\" ++ [ch]
| otherwise = [ch]
showVal (Prim _) = "<primitive>"
showVal (Func {params = args, vararg = varargs, body = bd,
closure = _, name = nm, macro = ismac}) =
let lopen = if ismac then "<macro" else "(lambda"
lclose = if ismac then ">" else ")"
inner = lopen ++ " (" ++ (unwords args) ++
(case varargs of
Nothing -> ""
Just arg -> " . " ++ arg) ++ ") " ++
(unwords (map showVal bd)) ++ lclose
in case nm of
Nothing -> inner
Just val -> "(" ++ val ++ " . " ++ inner ++ ")"
showVal (IOPrim _) = "<IO primitive>"
showVal (Port _) = "<IO port>"
showVal (Socket _) = "<IO socket>"
showVal (Delay {obj = o, closure = _, tag = _}) = "<promise>" ++ (show o)
showVal (Vector _ vals) =
"#(" ++ (unwords (map showVal (DIM.elems vals))) ++ ")"
-- True and False at the scheme level
lispTrue, lispFalse :: LispVal
lispTrue = Boolean True
lispFalse = Boolean False
-- A lisp error: these get processed when an error of some kind occurs
data LispError = NumArgs String Integer [LispVal]
| TypeMismatch String String LispVal
| Parser ParseError
| BadSpecial String LispVal
| NotFunction String LispVal
| UnboundVar String String
| Default String
| OutOfRange String Double
| VectorBounds Integer LispVal
| UserException LispVal
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
showError :: LispError -> String
showError (NumArgs func expected found) =
func ++ " expected " ++ show expected ++ " args; got values \"" ++
(unwords (map showVal found)) ++ "\""
showError (TypeMismatch func expected found) =
func ++ " expected " ++ expected ++ " args; got " ++ (show found)
showError (Parser parseErr) = "Parse error at " ++ (show parseErr)
showError (BadSpecial msg form) = msg ++ ": \"" ++ (show form) ++ "\""
showError (NotFunction msg func) = msg ++ ": " ++ (show func)
showError (UnboundVar msg var) = msg ++ ": " ++ var
showError (Default msg) = msg
showError (OutOfRange func val) = func ++ " arg out of range: " ++ (show val)
showError (VectorBounds len n) =
"vector index out of bounds: " ++ (show n) ++
" not in [0.." ++ (show (len - 1)) ++ "]"
showError (UserException val) = "user exception " ++ (show val)
type ThrowsError = Either LispError
type IOThrowsError = ErrorT LispError IO
-- convert a ThrowsError foo value into an IOThrowsError foo value
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val