{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE ViewPatterns #-}{- |
Module : Language.Scheme.Types
Copyright : Justin Ethier
Licence : MIT (see LICENSE in the distribution)
Maintainer : github.com/justinethier
Stability : experimental
Portability : portable
This module contains top-level data type definitions, environments, error types, and associated functions.
-}moduleLanguage.Scheme.Types(Env(..),nullEnv,LispError(..),ThrowsError,trapError,extractValue,IOThrowsError,liftThrows,runIOThrowsREPL,runIOThrows,LispVal(Atom,List,DottedList,Vector,HashTable,Number,Float,Complex,Rational,String,Char,Bool,PrimitiveFunc,Func,params,vararg,body,closure,HFunc,hparams,hvararg,hbody,hclosure,IOFunc,EvalFunc,Pointer,pointerVar,pointerEnv,Opaque,Port,Continuation,contClosure,currentCont,nextCont,extraReturnArgs,dynamicWind,Syntax,synClosure,synRenameClosure,synDefinedInMacro,synIdentifiers,synRules,SyntaxExplicitRenaming,EOF,Nil),toOpaque,fromOpaque,DeferredCode(..),DynamicWinders(..),makeNullContinuation,makeCPS,makeCPSWArgs,eqv,eqvList,eqVal,makeFunc,makeNormalFunc,makeVarargs,makeHFunc,makeNormalHFunc,makeHVarargs)whereimportControl.Monad.ErrorimportData.CompleximportData.ArrayimportData.DynamicimportData.IORefimportqualifiedData.Map-- import Data.MaybeimportData.RatioimportSystem.IOimportText.ParserCombinators.Parsechiding(spaces)-- Environment management-- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@dataEnv=Environment{parentEnv::(MaybeEnv),bindings::(IORef(Data.Map.MapString(IORefLispVal))),pointers::(IORef(Data.Map.MapString(IORef[LispVal])))}-- |An empty environmentnullEnv::IOEnvnullEnv=donullBindings<-newIORef$Data.Map.fromList[]nullPointers<-newIORef$Data.Map.fromList[]return$EnvironmentNothingnullBindingsnullPointers-- |Types of errors that may occur when evaluating Scheme codedataLispError=NumArgsInteger[LispVal]-- ^Invalid number of function arguments|TypeMismatchStringLispVal-- ^Type error|ParserParseError-- ^Parsing error|BadSpecialFormStringLispVal-- ^Invalid special (built-in) form|NotFunctionStringString|UnboundVarStringString|DivideByZero-- ^Divide by Zero error|NotImplementedString|InternalErrorString{- ^An internal error within husk; in theory user (Scheme) code
should never allow one of these errors to be triggered. -}|DefaultString-- ^Default error-- |Create a textual description for a 'LispError'showError::LispError->StringshowError(NumArgsexpectedfound)="Expected "++showexpected++" args; found values "++unwordsListfoundshowError(TypeMismatchexpectedfound)="Invalid type: expected "++expected++", found "++showfoundshowError(ParserparseErr)="Parse error at "++": "++showparseErrshowError(BadSpecialFormmessageform)=message++": "++showformshowError(NotFunctionmessagefunc)=message++": "++showfuncshowError(UnboundVarmessagevarname)=message++": "++varnameshowError(DivideByZero)="Division by zero"showError(NotImplementedmessage)="Not implemented: "++messageshowError(InternalErrormessage)="An internal error occurred: "++messageshowError(Defaultmessage)="Error: "++messageinstanceShowLispErrorwhereshow=showErrorinstanceErrorLispErrorwherenoMsg=Default"An error has occurred"strMsg=DefaulttypeThrowsError=EitherLispErrortrapError::-- forall (m :: * -> *) e.(MonadErrorem,Showe)=>mString->mStringtrapErroraction=catchErroraction(return.show)extractValue::ThrowsErrora->aextractValue(Rightval)=valextractValue(Left_)=error"Unexpected error in extractValue; "typeIOThrowsError=ErrorTLispErrorIOliftThrows::ThrowsErrora->IOThrowsErroraliftThrows(Lefterr)=throwErrorerrliftThrows(Rightval)=returnval-- |Execute an IO action and return result or an error message.-- This is intended for use by a REPL, where a result is always-- needed regardless of type.runIOThrowsREPL::IOThrowsErrorString->IOStringrunIOThrowsREPLaction=runErrorT(trapErroraction)>>=return.extractValue-- |Execute an IO action and return error or Nothing if no error was thrown.runIOThrows::IOThrowsErrorString->IO(MaybeString)runIOThrowsaction=dorunState<-runErrorTactioncaserunStateofLefterr->return$Just(showerr)Right_->return$Nothing-- |Scheme data typesdataLispVal=AtomString-- ^Symbol|List[LispVal]-- ^List|DottedList[LispVal]LispVal-- ^Pair|Vector(ArrayIntLispVal)-- ^Vector|HashTable(Data.Map.MapLispValLispVal){- ^Hash table.
Technically this could be a derived data type instead of being built-in to the
interpreter. And perhaps in the future it will be. But for now, a hash table
is too important of a data type to not be included. -}---- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> Map has good performance characteristics compared to the alternatives. So it stays for the moment...--|NumberInteger{- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful)
Integer -}|FloatDouble{- FUTURE: rename this "Real" instead of "Float"...
Floating point -}|Complex(ComplexDouble)-- ^Complex number|RationalRational-- ^Rational number|StringString-- ^String|CharChar-- ^Character|BoolBool-- ^Boolean|PrimitiveFunc([LispVal]->ThrowsErrorLispVal)-- ^Primitive function|Func{params::[String],vararg::(MaybeString),body::[LispVal],closure::Env}-- ^Function|HFunc{hparams::[String],hvararg::(MaybeString),hbody::(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal),hclosure::Env}-- ^Function formed from a Haskell function|IOFunc([LispVal]->IOThrowsErrorLispVal)-- ^Primitive function within the IO monad|EvalFunc([LispVal]->IOThrowsErrorLispVal){- ^Function within the IO monad with access to
the current environment and continuation. -}|Pointer{pointerVar::String,pointerEnv::Env}-- ^Pointer to an environment variable.|OpaqueDynamic-- ^Opaque Haskell value.|PortHandle-- ^I/O port|Continuation{contClosure::Env-- Environment of the continuation,currentCont::(MaybeDeferredCode)-- Code of current continuation,nextCont::(MaybeLispVal)-- Code to resume after body of cont,extraReturnArgs::(Maybe[LispVal])-- Extra return arguments, to support (values) and (call-with-values),dynamicWind::(Maybe[DynamicWinders])-- Functions injected by (dynamic-wind)}-- ^Continuation|Syntax{synClosure::MaybeEnv-- ^ Code env in effect at definition time, if applicable,synRenameClosure::MaybeEnv-- ^ Renames (from macro hygiene) in effect at def time;-- only applicable if this macro defined inside another macro.,synDefinedInMacro::Bool,synIdentifiers::[LispVal]-- ^ Literal identifiers from syntax-rules ,synRules::[LispVal]-- ^ Rules from syntax-rules}-- ^ Type to hold a syntax object that is created by a macro definition.-- Syntax objects are not used like regular types in that they are not-- passed around within variables. In other words, you cannot use set! to-- assign a variable to a syntax object. But they are used during function-- application. In any case, it is convenient to define the type here -- because syntax objects are stored in the same environments and -- manipulated by the same functions as regular variables.|SyntaxExplicitRenamingLispVal-- ^ Syntax for an explicit-renaming macro|EOF|NilString-- ^Internal use only; do not use this type directly.-- |Convert a Haskell value to an opaque Lisp value.toOpaque::Typeablea=>a->LispValtoOpaque=Opaque.toDyn-- |Convert an opaque Lisp value back into a Haskell value of the appropriate-- type, or produce a TypeMismatch error.fromOpaque::foralla.Typeablea=>LispVal->ThrowsErrora-- fromOpaque (Opaque o) | isJust $ fromDynamic o = fromJust $ fromDynamic o-- fromOpaque badArg = throwError $ TypeMismatch (show $ toOpaque (undefined :: a)) badArg-- Old version that used ViewPatternsfromOpaque(Opaque(fromDynamic->Justv))=returnvfromOpaquebadArg=throwError$TypeMismatch(show$toOpaque(undefined::a))badArg-- |Container to hold code that is passed to a continuation for deferred executiondataDeferredCode=SchemeBody[LispVal]|-- ^A block of Scheme codeHaskellBody{contFunction::(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal),contFunctionArgs::(Maybe[LispVal])-- Arguments to the higher-order function}-- ^A Haskell function-- |Container to store information from a dynamic-winddataDynamicWinders=DynamicWinders{before::LispVal-- ^Function to execute when resuming continuation within extent of dynamic-wind,after::LispVal-- ^Function to execute when leaving extent of dynamic-wind}showDWVal::DynamicWinders->StringshowDWVal(DynamicWindersba)="("++(showb)++" . "++(showa)++")"instanceShowDynamicWinderswhereshow=showDWVal-- Make an "empty" continuation that does not contain any codemakeNullContinuation::Env->LispValmakeNullContinuationenv=ContinuationenvNothingNothingNothingNothing-- Make a continuation that takes a higher-order function (written in Haskell)makeCPS::Env->LispVal->(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal)->LispValmakeCPSenvcont@(Continuation____dynWind)cps=Continuationenv(Just(HaskellBodycpsNothing))(Justcont)NothingdynWindmakeCPSenvcontcps=Continuationenv(Just(HaskellBodycpsNothing))(Justcont)NothingNothing-- This overload just here for completeness; it should never be used-- Make a continuation that stores a higher-order function and arguments to that functionmakeCPSWArgs::Env->LispVal->(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal)->[LispVal]->LispValmakeCPSWArgsenvcont@(Continuation____dynWind)cpsargs=Continuationenv(Just(HaskellBodycps(Justargs)))(Justcont)NothingdynWindmakeCPSWArgsenvcontcpsargs=Continuationenv(Just(HaskellBodycps(Justargs)))(Justcont)NothingNothing-- This overload just here for completeness; it should never be usedinstanceOrdLispValwherecompare(Boola)(Boolb)=compareabcompare(Numbera)(Numberb)=compareabcompare(Rationala)(Rationalb)=compareabcompare(Floata)(Floatb)=compareabcompare(Stringa)(Stringb)=compareabcompare(Chara)(Charb)=compareabcompare(Atoma)(Atomb)=compareab{- compare (DottedList xs x) (DottedList xs x) = compare a b
Vector
HashTable
List
Func
Others? -}compareab=compare(showa)(showb)-- Hack (??): sort alphabetically when types differ or have no handlers-- |Compare two 'LispVal' instanceseqv::[LispVal]->ThrowsErrorLispValeqv[(Boolarg1),(Boolarg2)]=return$Bool$arg1==arg2eqv[(Numberarg1),(Numberarg2)]=return$Bool$arg1==arg2eqv[(Complexarg1),(Complexarg2)]=return$Bool$arg1==arg2eqv[(Rationalarg1),(Rationalarg2)]=return$Bool$arg1==arg2eqv[(Floatarg1),(Floatarg2)]=return$Bool$arg1==arg2eqv[(Stringarg1),(Stringarg2)]=return$Bool$arg1==arg2eqv[(Chararg1),(Chararg2)]=return$Bool$arg1==arg2eqv[(Atomarg1),(Atomarg2)]=return$Bool$arg1==arg2eqv[(DottedListxsx),(DottedListysy)]=eqv[List$xs++[x],List$ys++[y]]eqv[(Vectorarg1),(Vectorarg2)]=eqv[List$(elemsarg1),List$(elemsarg2)]eqv[(HashTablearg1),(HashTablearg2)]=eqv[List$(map(\(x,y)->List[x,y])$Data.Map.toAscListarg1),List$(map(\(x,y)->List[x,y])$Data.Map.toAscListarg2)]---- This comparison function may be too simplistic. Basically we check to see if-- functions have the same calling interface. If they do, then we compare the -- function bodies for equality.----FUTURE:---- The real solution for this and many of the other comparison functions is to-- assign memory locations to data. Then we can just compare memory locations-- in cases such as this one. But that is a much larger change.eqv[x@(Func__xBody_),y@(Func__yBody_)]=doif(showx)/=(showy)thenreturn$BoolFalseelseeqvListeqv[ListxBody,ListyBody]eqv[x@(HFunc____),y@(Func____)]=doif(showx)/=(showy)thenreturn$BoolFalseelsereturn$BoolTrue-- TODO: compare high-order functions... eqvList eqv [List xBody, List yBody] --eqv[x@(PrimitiveFunc_),y@(PrimitiveFunc_)]=return$Bool$(showx)==(showy)eqv[x@(IOFunc_),y@(IOFunc_)]=return$Bool$(showx)==(showy)eqv[x@(EvalFunc_),y@(EvalFunc_)]=return$Bool$(showx)==(showy)-- FUTURE: comparison of two continuationseqv[l1@(List_),l2@(List_)]=eqvListeqv[l1,l2]eqv[_,_]=return$BoolFalseeqvbadArgList=throwError$NumArgs2badArgList-- |Compare two lists of haskell values, using the given comparison functioneqvList::([LispVal]->ThrowsErrorLispVal)->[LispVal]->ThrowsErrorLispValeqvListeqvFunc[(Listarg1),(Listarg2)]=return$Bool$(lengtharg1==lengtharg2)&&(alleqvPair$ziparg1arg2)whereeqvPair(x1,x2)=caseeqvFunc[x1,x2]ofLeft_->FalseRight(Boolval)->val_->False-- OK?eqvList__=throwError$Default"Unexpected error in eqvList"eqVal::LispVal->LispVal->BooleqValab=doletresult=eqv[a,b]caseresultofLeft_->FalseRight(Boolval)->val_->False-- Is this OK?instanceEqLispValwherex==y=eqValxy-- |Create a textual description of a 'LispVal'showVal::LispVal->StringshowVal(Nil_)=""showVal(EOF)="#!EOF"showVal(Stringcontents)="\""++contents++"\""showVal(Charchr)=[chr]showVal(Atomname)=nameshowVal(Numbercontents)=showcontentsshowVal(Complexcontents)=(show$realPartcontents)++"+"++(show$imagPartcontents)++"i"showVal(Rationalcontents)=(show(numeratorcontents))++"/"++(show(denominatorcontents))showVal(Floatcontents)=showcontentsshowVal(BoolTrue)="#t"showVal(BoolFalse)="#f"showVal(Vectorcontents)="#("++(unwordsList$Data.Array.elemscontents)++")"showVal(HashTable_)="<hash-table>"showVal(Listcontents)="("++unwordsListcontents++")"showVal(DottedListht)="("++unwordsListh++" . "++showValt++")"showVal(PrimitiveFunc_)="<primitive>"showVal(Continuation_____)="<continuation>"showVal(Syntax_____)="<syntax>"showVal(SyntaxExplicitRenaming_)="<er-macro-transformer syntax>"showVal(Func{params=args,vararg=varargs,body=_,closure=_})="(lambda ("++unwords(mapshowargs)++(casevarargsofNothing->""Justarg->" . "++arg)++") ...)"showVal(HFunc{hparams=args,hvararg=varargs,hbody=_,hclosure=_})="(lambda ("++unwords(mapshowargs)++(casevarargsofNothing->""Justarg->" . "++arg)++") ...)"showVal(Port_)="<IO port>"showVal(IOFunc_)="<IO primitive>"showVal(EvalFunc_)="<procedure>"showVal(Pointerp_)="<ptr "++p++">"showVal(Opaqued)="<Haskell "++show(dynTypeRepd)++">"-- |Convert a list of Lisp objects into a space-separated stringunwordsList::[LispVal]->StringunwordsList=unwords.mapshowVal-- |Allow conversion of lispval instances to stringsinstanceShowLispValwhereshow=showVal-- Functions required by the interpreter ---- |Create a scheme functionmakeFunc::-- forall (m :: * -> *).(Monadm)=>MaybeString->Env->[LispVal]->[LispVal]->mLispValmakeFuncvarargsenvfparamsfbody=return$Func(mapshowValfparams)varargsfbodyenv-- |Create a normal scheme functionmakeNormalFunc::(Monadm)=>Env->[LispVal]->[LispVal]->mLispValmakeNormalFunc=makeFuncNothing-- |Create a scheme function that can receive any number of argumentsmakeVarargs::(Monadm)=>LispVal->Env->[LispVal]->[LispVal]->mLispValmakeVarargs=makeFunc.Just.showVal-- Functions required by a compiled program ---- |Create a haskell functionmakeHFunc::(Monadm)=>MaybeString->Env->[String]->(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal)-- -> String ->mLispValmakeHFuncvarargsenvfparamsfbody=return$HFuncfparamsvarargsfbodyenv--(map showVal fparams) varargs fbody env-- |Create a normal haskell functionmakeNormalHFunc::(Monadm)=>Env->[String]->(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal)->mLispValmakeNormalHFunc=makeHFuncNothing-- |Create a haskell function that can receive any number of argumentsmakeHVarargs::(Monadm)=>LispVal->Env->[String]->(Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispVal)->mLispValmakeHVarargs=makeHFunc.Just.showVal