module Language.Egison.Types where
import Control.Monad.Error
import Data.Complex()
import Data.Array()
import Data.Dynamic()
import Data.IORef
import qualified Data.Map
import System.IO
import Text.ParserCombinators.Parsec hiding (spaces)
data EgisonError = NumArgs Integer [EgisonVal]
| TypeMismatch String EgisonVal
| Parser ParseError
| BadSpecialForm String [EgisonVal]
| NotFunction String String
| UnboundVar String String
| DivideByZero
| NotImplemented String
| InternalError String
| Default String
showError :: EgisonError -> String
showError (NumArgs expected found) = "Expected " ++ show expected
++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr
showError (BadSpecialForm message args) = message ++ ": " ++ unwordsList args
showError (NotFunction message func) = message ++ ": " ++ show func
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (DivideByZero) = "Division by zero"
showError (NotImplemented message) = "Not implemented: " ++ message
showError (InternalError message) = "An internal error occurred: " ++ message
showError (Default message) = "Error: " ++ message
instance Show EgisonError where show = showError
instance Error EgisonError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either EgisonError
trapError :: (MonadError e m, Show e) => m String -> m String
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
extractValue (Left _) = error "Unexpected error in extractValue; "
type IOThrowsError = ErrorT EgisonError IO
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val
runIOThrowsREPL :: IOThrowsError String -> IO String
runIOThrowsREPL action = runErrorT (trapError action) >>= return . extractValue
runIOThrows :: IOThrowsError String -> IO (Maybe String)
runIOThrows action = do
runState <- runErrorT action
case runState of
Left err -> return $ Just (show err)
Right _ -> return $ Nothing
data TopExpr = Define String EgisonExpr
| Test EgisonExpr
| Execute [String]
| LoadFile String
| Load String
data EgisonExpr = CharExpr Char
| StringExpr String
| BoolExpr Bool
| NumberExpr Integer
| FloatExpr Double
| VarExpr String [EgisonExpr]
| SymbolExpr String [EgisonExpr]
| PatVarExpr String [EgisonExpr]
| WildCardExpr
| PatVarOmitExpr EgisonExpr
| CutPatExpr EgisonExpr
| NotPatExpr EgisonExpr
| AndPatExpr [EgisonExpr]
| OrPatExpr [EgisonExpr]
| PredPatExpr String [EgisonExpr]
| InductiveDataExpr String [EgisonExpr]
| TupleExpr [InnerExpr]
| CollectionExpr [InnerExpr]
| FuncExpr Args EgisonExpr
| LoopExpr String String EgisonExpr EgisonExpr EgisonExpr
| ParamsExpr String EgisonExpr EgisonExpr
| IfExpr EgisonExpr EgisonExpr EgisonExpr
| LetExpr Bindings EgisonExpr
| LetRecExpr RecursiveBindings EgisonExpr
| DoExpr Bindings EgisonExpr
| TypeExpr RecursiveBindings
| TypeRefExpr EgisonExpr String
| DestructorExpr DestructInfoExpr
| MatchExpr EgisonExpr EgisonExpr [MatchClause]
| MatchAllExpr EgisonExpr EgisonExpr MatchClause
| ApplyExpr EgisonExpr EgisonExpr
type ArgsExpr = Args
type MatchClause = (EgisonExpr, EgisonExpr)
data PrimitivePattern = PWildCard
| PPatVar String
| PInductivePat String [PrimitivePattern]
| PEmptyPat
| PConsPat PrimitivePattern PrimitivePattern
| PSnocPat PrimitivePattern PrimitivePattern
| PPatBool Bool
| PPatChar Char
| PPatNumber Integer
| PPatFloat Double
data InnerExpr = ElementExpr EgisonExpr
| SubCollectionExpr EgisonExpr
type Bindings = [(Args, EgisonExpr)]
type RecursiveBindings = [(String, EgisonExpr)]
type DestructInfoExpr = [(String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])]
type ObjectRef = IORef Object
data Object = Closure Env EgisonExpr
| Value EgisonVal
| Intermidiate IntermidiateVal
| Loop String String ObjectRef EgisonExpr EgisonExpr
data EgisonVal = World [Action]
| Char Char
| String String
| Bool Bool
| Number Integer
| Float Double
| WildCard
| PatVar String [Integer]
| PredPat String [ObjectRef]
| CutPat ObjectRef
| NotPat ObjectRef
| AndPat [ObjectRef]
| OrPat [ObjectRef]
| InductiveData String [EgisonVal]
| Tuple [InnerVal]
| Collection [InnerVal]
| Type Frame
| Destructor DestructInfo
| Func Args EgisonExpr Env
| PrimitiveFunc ([EgisonVal] -> ThrowsError EgisonVal)
| IOFunc ([EgisonVal] -> IOThrowsError EgisonVal)
| Port String Handle
| EOF
data IntermidiateVal = IInductiveData String [ObjectRef]
| ITuple [InnerValRef]
| ICollection [InnerValRef]
data Action = OpenInputPort String
| OpenOutputPort String
| ClosePort String
| FlushPort String
| ReadFromPort String String
| WriteToPort String String
data Args = AVar String
| ATuple [Args]
data InnerVal = Element EgisonVal
| SubCollection EgisonVal
innerValsToList :: [InnerVal] -> [EgisonVal]
innerValsToList [] = []
innerValsToList ((Element val):rest) = val:(innerValsToList rest)
innerValsToList ((SubCollection (Collection iVals)):rest) = (innerValsToList iVals) ++ (innerValsToList rest)
tupleToList :: EgisonVal -> [EgisonVal]
tupleToList (Tuple innerVals) = innerValsToList innerVals
tupleToList val = [val]
collectionToList :: EgisonVal -> [EgisonVal]
collectionToList (Collection innerVals) = innerValsToList innerVals
valsToObjRefList :: [EgisonVal] -> IO [ObjectRef]
valsToObjRefList vals = mapM newIORef (map Value vals)
makeTupleFromValList :: [EgisonVal] -> EgisonVal
makeTupleFromValList vals = Tuple $ map Element vals
makeCollectionFromValList :: [EgisonVal] -> EgisonVal
makeCollectionFromValList vals = Collection $ map Element vals
data InnerValRef = IElement ObjectRef
| ISubCollection ObjectRef
type DestructInfo = [(String, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]
type VarExpr = (String, [EgisonExpr])
type Var = (String, [Integer])
type FrameList = [(Var, ObjectRef)]
type Frame = Data.Map.Map Var ObjectRef
type FrameRef = IORef Frame
data Env = Environment {
parentEnv :: (Maybe Env),
topFrameRef :: FrameRef
}
nullEnv :: IO Env
nullEnv = do nullBindings <- newIORef $ Data.Map.fromList []
return $ Environment Nothing nullBindings
makeClosure :: Env -> EgisonExpr -> IO ObjectRef
makeClosure env expr = newIORef $ Closure env expr
makeInnerValRef :: Env -> InnerExpr -> IO InnerValRef
makeInnerValRef env (ElementExpr expr) = do
objRef <- makeClosure env expr
return $ IElement objRef
makeInnerValRef env (SubCollectionExpr expr) = do
objRef <- makeClosure env expr
return $ ISubCollection objRef
data MatchFlag = MAll | MOne
data PClosure = PClosure {pcFrame :: FrameList,
pcBody :: ObjectRef
}
data MAtom = MAtom {pClosure :: PClosure,
maTyp :: ObjectRef,
maTarget :: ObjectRef
}
data MState = MState {msFrame :: FrameList,
mAtoms :: [MAtom]
}
unwordsList :: Show a => [a] -> String
unwordsList = unwords . map show
unwordsNums :: Show a => [a] -> String
unwordsNums [] = ""
unwordsNums (n:ns) = "_" ++ show n ++ unwordsNums ns
showVar :: (String, [Integer]) -> String
showVar (name, nums) = name ++ unwordsNums nums
showBindings :: Bindings -> String
showBindings [] = "{}"
showBindings bindings = "{" ++ unwords (map showBinding bindings) ++ "}"
where showBinding (_,expr) = "[$" ++ "..." ++ " " ++ show expr ++ "]"
showRecursiveBindings :: RecursiveBindings -> String
showRecursiveBindings [] = "{}"
showRecursiveBindings bind = "{" ++ unwords (map showBinding bind) ++ "}"
where showBinding (_,expr) = "[$" ++ "..." ++ " " ++ show expr ++ "]"
showExpr :: EgisonExpr -> String
showExpr (CharExpr chr) = [chr]
showExpr (StringExpr contents) = contents
showExpr (BoolExpr True) = "#t-expr"
showExpr (BoolExpr False) = "#f-expr"
showExpr (NumberExpr contents) = show contents
showExpr (FloatExpr contents) = show contents
showExpr (VarExpr name nums) = name ++ unwordsNums nums
showExpr (SymbolExpr name nums) = "#" ++ name ++ unwordsNums nums
showExpr (PatVarExpr name nums) = "$" ++ name ++ unwordsNums nums
showExpr WildCardExpr = "_"
showExpr (PatVarOmitExpr pvar) = "(omit " ++ show pvar ++ ")"
showExpr (CutPatExpr _) = "#<cut-pat>"
showExpr (NotPatExpr _) = "#<not-pat>"
showExpr (AndPatExpr _) = "#<and-pat>"
showExpr (OrPatExpr _) = "#<or-pat>"
showExpr (PredPatExpr _ _) = "#<pred-pat>"
showExpr (InductiveDataExpr cons _) = "<" ++ cons ++ "...>"
showExpr (TupleExpr _) = "[...]"
showExpr (CollectionExpr _) = "{...}"
showExpr (FuncExpr _ _) =
"(lambda [" ++ "..." ++ "] ...)"
showExpr (LoopExpr lVar iVar rExpr lExpr tExpr) =
"(loop $" ++ lVar ++ " $" ++ iVar ++ " " ++ show rExpr ++ " " ++ show lExpr ++ " " ++ show tExpr ++ ")"
showExpr (ParamsExpr pVar pExpr body) =
"(loop $" ++ pVar ++ " " ++ show pExpr ++ " " ++ show body ++ ")"
showExpr (IfExpr condExpr expr1 expr2) =
"(if " ++ show condExpr ++ " " ++ show expr1 ++ " " ++ show expr2 ++ ")"
showExpr (LetExpr bindings body) =
"(let " ++ showBindings bindings ++ " " ++ show body ++ ")"
showExpr (LetRecExpr bindings body) =
"(letrec " ++ showRecursiveBindings bindings ++ " " ++ show body ++ ")"
showExpr (DoExpr bindings body) =
"(do " ++ showBindings bindings ++ " " ++ show body ++ ")"
showExpr (TypeExpr bindings) =
"(type " ++ showRecursiveBindings bindings ++ ")"
showExpr (TypeRefExpr typExpr name) =
"(type-ref " ++ show typExpr ++ " " ++ name ++ ")"
showExpr (DestructorExpr _) = "(destructor ...)"
showExpr (MatchExpr tgtExpr typExpr _) =
"(match " ++ show tgtExpr ++ " " ++ show typExpr ++ " ...)"
showExpr (MatchAllExpr tgtExpr typExpr _) =
"(match-all " ++ show tgtExpr ++ " " ++ show typExpr ++ " ...)"
showExpr (ApplyExpr opExpr argExpr) =
"(" ++ show opExpr ++ " " ++ show argExpr ++ ")"
instance Show EgisonExpr where show = showExpr
eqv :: [EgisonVal] -> ThrowsError EgisonVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2
eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
eqVal :: EgisonVal -> EgisonVal -> Bool
eqVal a b = do
let result = eqv [a, b]
case result of
Left _ -> False
Right (Bool val) -> val
_ -> False
instance Eq EgisonVal where
x == y = eqVal x y
showVal :: EgisonVal -> String
showVal (World _) = "#<world>"
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Char chr) = "'" ++ [chr] ++ "'"
showVal (String str) = "\"" ++ str ++ "\""
showVal (Number contents) = show contents
showVal (Float contents) = show contents
showVal WildCard = "_"
showVal (PatVar name nums) = "$" ++ name ++ unwordsNums nums
showVal (CutPat _) = "#<cut-pat>"
showVal (NotPat _) = "#<not-pat>"
showVal (AndPat _) = "#<and-pat>"
showVal (OrPat _) = "#<or-pat>"
showVal (PredPat _ _) = "#<pred-pat>"
showVal (InductiveData cons []) = "<" ++ cons ++ ">"
showVal (InductiveData cons args) = "<" ++ cons ++ " " ++ unwordsList args ++ ">"
showVal (Tuple innerVals) = "[" ++ showInnerVals innerVals ++ "]"
showVal (Collection innerVals) = "{" ++ showInnerVals innerVals ++ "}"
showVal (Type _) = "#<type>"
showVal (Destructor _) = "#<destructor>"
showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)"
showVal (PrimitiveFunc _) = "#<primitive>"
showVal (IOFunc _) = "#<IO primitive>"
showVal (Port _ _) = "#<IO port>"
showVal EOF = "#!EOF"
instance Show EgisonVal where show = showVal
showInnerVals :: [InnerVal] -> String
showInnerVals iVals = unwordsList $ innerValsToList iVals
showIVal :: IntermidiateVal -> String
showIVal (IInductiveData cons []) = "<" ++ cons ++ ">"
showIVal (IInductiveData cons _) = "<" ++ cons ++ " " ++ "..." ++ ">"
showIVal (ITuple _) = "[" ++ "..." ++ "]"
showIVal (ICollection _) = "{" ++ "..." ++ "}"
instance Show IntermidiateVal where show = showIVal
showObj :: Object -> String
showObj (Closure _ expr) = "(Closure env " ++ show expr ++ ")"
showObj (Value val) = "(Value " ++ show val ++ ")"
showObj (Intermidiate val) = "(Intermidiate " ++ show val ++ ")"
showObj (Loop _ _ _ _ _) = "#<loop>"
instance Show Object where show = showObj
showFrameList :: FrameList -> String
showFrameList [] = "{}"
showFrameList (((name,nums),_):rest) = "{[" ++ name ++ unwordsNums nums ++ ": _]" ++ loop rest
where loop [] = "}"
loop (((name2,nums2),_):rest2) = " [" ++ name2 ++ unwordsNums nums2 ++ ": _]" ++ loop rest2
stringToCharCollection :: String -> IO EgisonVal
stringToCharCollection = undefined