egison 1.2.3 → 2.0.0
raw patch · 31 files changed
+3339/−3159 lines, 31 filesdep +arraydep +containersdep +directory
Dependencies added: array, containers, directory, egison, ghc, ghc-paths, haskeline, transformers
Files
- Egison.hs +0/−2145
- egison.cabal +23/−47
- elisp/egison-mode.el +165/−0
- etc/elisp/egison-mode.el +0/−162
- etc/lib/base.egi +0/−65
- etc/lib/collection.egi +0/−193
- etc/lib/graph.egi +0/−43
- etc/lib/number.egi +0/−62
- etc/lib/poker-hands.egi +0/−110
- etc/sample/collection-test.egi +0/−200
- etc/sample/graph-test.egi +0/−34
- etc/sample/io-test.egi +0/−37
- etc/sample/number-test.egi +0/−38
- etc/sample/poker-hands-test.egi +0/−23
- hs-src/Interpreter/egisoni.hs +88/−0
- hs-src/Language/Egison/Core.hs +816/−0
- hs-src/Language/Egison/Numerical.hs +156/−0
- hs-src/Language/Egison/Parser.hs +490/−0
- hs-src/Language/Egison/Primitives.hs +203/−0
- hs-src/Language/Egison/Types.hs +421/−0
- hs-src/Language/Egison/Variables.hs +126/−0
- lib/core/base.egi +70/−0
- lib/core/collection.egi +207/−0
- lib/core/number.egi +69/−0
- lib/graph.egi +40/−0
- lib/poker-hands.egi +110/−0
- sample/collection-test.egi +184/−0
- sample/graph-test.egi +34/−0
- sample/io-test.egi +76/−0
- sample/number-test.egi +38/−0
- sample/poker-hands-test.egi +23/−0
− Egison.hs
@@ -1,2145 +0,0 @@-module Main where--import System.Environment-import Control.Monad-import Control.Monad.Error-import Data.IORef---import qualified Data.HashMap as Hash-import Text.Parsec hiding (spaces)-import Text.Parsec.String (Parser)-import qualified Text.Parsec.Token as P-import Text.Parsec.Language (haskellDef)-import System.IO-import Control.Exception (catch, SomeException)-import Prelude hiding (catch)--import Paths_egison--welcomeMsg :: String-welcomeMsg = "Egison, version 1.2.3 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"--byebyeMsg :: String-byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n"--data Input = Input String- | Eof- -readPrompt :: String -> IO Input-readPrompt prompt = flushStr prompt >> getExpression--flushStr :: String -> IO ()-flushStr str = putStr str >> hFlush stdout--removeComment :: String -> String-removeComment "" = ""-removeComment (c:cs) = case c of- ';' -> removeCommentHelper cs- _ -> c:(removeComment cs)--removeCommentHelper :: String -> String-removeCommentHelper "" = ""-removeCommentHelper (c:cs) = case c of- '\n' -> removeComment cs- _ -> removeCommentHelper cs--getExpressionHelper :: Bool -> Integer -> IO String-getExpressionHelper b n = do c <- getChar- case c of- '(' -> do l <- getExpressionHelper True (n + 1)- return (c : l)- '<' -> do l <- getExpressionHelper True (n + 1)- return (c : l)- '[' -> do l <- getExpressionHelper True (n + 1)- return (c : l)- '{' -> do l <- getExpressionHelper True (n + 1)- return (c : l)- ')' -> do l <- getExpressionHelper True (n - 1)- return (c : l)- '>' -> do l <- getExpressionHelper True (n - 1)- return (c : l)- ']' -> do l <- getExpressionHelper True (n - 1)- return (c : l)- '}' -> do l <- getExpressionHelper True (n - 1)- return (c : l)- '\n' -> if n > 0- then do l <- getExpressionHelper b n- return (c : l)- else if b- then return "\n"- else getExpressionHelper b n- ' ' -> do l <- getExpressionHelper b n- return (c : l)- '\t' -> do l <- getExpressionHelper b n- return (c : l)- _ -> do l <- getExpressionHelper True n- return (c : l)- -getExpression :: IO Input-getExpression = catch (do str <- getExpressionHelper False 0- return (Input str))- (\e2 -> let e = e2 :: SomeException in- return Eof)-------- Error Handle---- -type IOThrowsError = ErrorT EgiError IO--data EgiError = Parser ParseError- | UnboundVariable String [Integer]- | WithTopExpression String Expression- | WithExpression String Expression- | Default String--showError :: EgiError -> String-showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n"-showError (UnboundVariable name nums) = "Error : unbound variable : " ++ name ++ unwordsNums nums ++ "\n"-showError (WithTopExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n"-showError (WithExpression str expr) = "Error : " ++ str ++ " : " ++ show expr ++ "\n"-showError (Default str) = "Error : " ++ str ++ "\n"--instance Show EgiError where show = showError--instance Error EgiError where- noMsg = Default "An error has occured"- strMsg = Default--type ThrowsError = Either EgiError--liftThrows :: ThrowsError a -> IOThrowsError a-liftThrows (Left err) = throwError err-liftThrows (Right val) = return val--runIOThrows :: IOThrowsError String -> IO String-runIOThrows action = runErrorT (trapError action) >>= return . extractValue--trapError :: (MonadError e m, Show e) => m String -> m String-trapError action = catchError action (return . show)--extractValue :: ThrowsError a -> a-extractValue (Right val) = val--readOrThrow :: Parser a -> String -> ThrowsError a-readOrThrow parser input = case parse parser "egison" input of- Left err -> throwError (Parser err)- Right val -> return val--readTopExpression :: String -> IOThrowsError TopExpression-readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr)--readTopExpressionList :: String -> IOThrowsError [TopExpression]-readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str)- -executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String-executeTopExpression defsRef (Define name numExprs expr) = do- liftIO (modifyIORef defsRef (\ls -> (((name,numExprs),expr) : ls)))- return (name ++ unwordsNums numExprs ++ "\n")-executeTopExpression defs (Test expr) = do- topFrame <- makeTopFrame defs- val <- eval [topFrame] expr- ret <- showValue val- return (ret ++ "\n")-executeTopExpression defs (Load libname) = do- filename <- liftIO (getDataFileName libname)- mStr <- liftIO (readEgisonFile filename)- case mStr of- Nothing -> throwError (Default "load error")- Just str -> do let str2 = removeComment str- topExprs <- readTopExpressionList str2- let loop topExprs2 = case topExprs2 of- [] -> return (filename ++ " loaded\n")- topExpr:rest -> do executeTopExpression defs topExpr- loop rest- loop topExprs-executeTopExpression defs (LoadFile filename) = do- mStr <- liftIO (readEgisonFile filename)- case mStr of- Nothing -> throwError (Default "load-file error")- Just str -> do let str2 = removeComment str- topExprs <- readTopExpressionList str2- let loop topExprs2 = case topExprs2 of- [] -> return (filename ++ " loaded\n")- topExpr:rest -> do executeTopExpression defs topExpr- loop rest- loop topExprs-executeTopExpression defs Execute = do- topFrame <- makeTopFrame defs- mainFn <- eval [topFrame] (VariableExp "main" [])- args <- liftIO (newIORef (Value (World [])))- case mainFn of- Function funEnv fpat body- -> do frame <- makeFrame fpat args- objRef <- liftIO (makeClosure (frame:funEnv) body)- cEval objRef- return ""- _ -> throwError (Default "main is not function")---readEgisonFile :: String -> IO (Maybe String)-readEgisonFile filename = catch (do str <- (readFile filename)- return (Just str))- (\e2 -> let e = e2 :: SomeException in- return Nothing)-- -runRepl :: Definitions -> IO ()-runRepl defsRef = do input <- (readPrompt "> ")- case input of- Eof -> flushStr byebyeMsg- Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defsRef) >>= flushStr >> runRepl defsRef--- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs--loadBasicLibrary :: Definitions -> Definitions-loadBasicLibrary defsRef = undefined--main :: IO ()-main = do args <- getArgs- case length args of- 0 -> do flushStr welcomeMsg- defsRef <- newIORef []- runRepl defsRef- _ -> putStrLn "Program takes only 0 argument!"------- Data Types-----data TopExpression = Define String [Expression] Expression- | Test Expression- | Load String- | LoadFile String- | Execute--data Expression = CharacterExp Char- | StringExp String- | IntegerExp Integer- | DoubleExp Double- | VariableExp String [Expression]- | SymbolExp String [Expression]- | OmitExp Expression- | InductiveDataExp String [Expression]- | TupleExp [InnerExp]- | CollectionExp [InnerExp]- | WildCardExp- | PatVarExp String [Expression]- | PatVarOmitExp Expression- | CutPatExp Expression- | NotPatExp Expression- | AndPatExp [Expression]- | OrPatExp [Expression]- | PredPatExp String [Expression]- | FunctionExp FunPat Expression- | MacroExp [String] Expression- | DoExp Bind Expression- | LetExp RecursiveBind Expression- | LoopExp Expression Expression Expression Expression Expression- | TypeExp RecursiveBind- | TypeRefExp Expression String- | DestructorExp DestructInfoExp- | MatchExp Expression Expression [MatchClause]- | MatchAllExp Expression Expression MatchClause- | MatchMaxExp Expression Expression MatchMaxClause- | ApplyExp Expression Expression- | ApplyListExp Expression [Expression]--data InnerExp = ElementExp Expression- | SubCollectionExp Expression--type Bind = [(FunPat, Expression)]--data FunPat = FunPatVar String- | FunPatTuple [FunPat]--type RecursiveBind = [((String, [Expression]), Expression)]--data MatchClause = MatchClause Expression Expression--data MatchMaxClause = MatchMaxClause Expression Expression Expression--type DestructInfoExp = [(String, Expression, [(PrimePat, Expression)])]--data PrimePat = PrimeWildCard- | PrimePatCharacter Char- | PrimePatInteger Integer- | PrimePatDouble Double- | PrimePatVar String- | InductivePrimePat String [PrimePat]- | EmptyPat- | ConsPat PrimePat PrimePat- | SnocPat PrimePat PrimePat--data Object = Closure Environment Expression- | Value Value--data Value = World [Action]- | Port Handle String- | Character Char- | Integer Integer- | Double Double- | InductiveData String [ObjectRef]- | Tuple [ObjectRef]- | Collection [InnerValue]- | Symbol String [Integer]- | WildCard- | PatVar String [Integer]- | PredPat String [ObjectRef]- | CutPat ObjectRef- | NotPat ObjectRef- | AndPat [ObjectRef]- | OrPat [ObjectRef]- | Function Environment FunPat Expression- | Expression Expression- | Macro [String] Expression- | Loop String String ObjectRef Expression Expression- | Type Frame- | DestructorFunction DestructInfo- | BuiltinFunction ([Value] -> IOThrowsError Value)--type ObjectRef = IORef Object- -data Action = Read Value- | Write Value- | Print String- | OpenInputFile String- | OpenOutputFile String- | CloseInputFile String- | CloseOutputFile String- | ReadFromPort String Value- | WriteToPort String Value- | PrintToPort String String- -data InnerValue = Element ObjectRef- | SubCollection ObjectRef--type DestructInfo = [(String, ObjectRef, [(Environment, PrimePat, Expression)])]--type Environment = [Frame]--type Frame = [Association]--type Association = ((String, [Integer]), ObjectRef)--type Definitions = IORef [((String, [Expression]), Expression)]--data PClosure = PClosure Frame ObjectRef--data MAtom = MAtom PClosure ObjectRef ObjectRef--data MState = MState Frame [MAtom]--isEqualValue :: Value -> Value -> IOThrowsError Bool-isEqualValue (Character c1) (Character c2) = return (c1 == c2)-isEqualValue (Integer n1) (Integer n2) = return (n1 == n2)-isEqualValue (Double d1) (Double d2) = return (d1 == d2)-isEqualValue (InductiveData c1 objRefs1) (InductiveData c2 objRefs2) =- if (c1 == c2)- then do vals1 <- cEvalList objRefs1- vals2 <- cEvalList objRefs2- isEqualValueList vals1 vals2- else return False-isEqualValue (Tuple objRefs1) (Tuple objRefs2) = do- vals1 <- cEvalList objRefs1- vals2 <- cEvalList objRefs2- isEqualValueList vals1 vals2-isEqualValue (Collection innerVals1) (Collection innerVals2) = do- vals1 <- innerValueListToValueList innerVals1- vals2 <- innerValueListToValueList innerVals2- isEqualValueList vals1 vals2-isEqualValue _ _ = return False--isEqualValueList :: [Value] -> [Value] -> IOThrowsError Bool-isEqualValueList [] [] = return True-isEqualValueList (v1:vals1) (v2:vals2) = do- b <- isEqualValue v1 v2- if b- then isEqualValueList vals1 vals2- else return False-isEqualValueList _ _ = return False --objectRefToInteger :: ObjectRef -> IOThrowsError Integer-objectRefToInteger objRef = do- obj <- liftIO (readIORef objRef)- case obj of- Value (Integer n) -> return n- _ -> throwError (Default "ojectRefToInteger: not Integer value")------- Environment----getValueFromFrame :: Frame -> (String,[Integer]) -> Maybe ObjectRef-getValueFromFrame [] _ = Nothing-getValueFromFrame (((var,nums1),objRef):rest) (var2,nums2) =- if var == var2 && nums1 == nums2- then Just objRef- else getValueFromFrame rest (var2,nums2)--getValue :: Environment -> (String,[Integer]) -> Maybe ObjectRef-getValue [] _ = Nothing-getValue (frame:env) (var,nums) =- let mObjRef = getValueFromFrame frame (var,nums)in- case mObjRef of- Nothing -> getValue env (var,nums)- Just objRef -> Just objRef--makeExpression :: Expression -> IO ObjectRef-makeExpression expr = newIORef (Value (Expression expr))--makeExpressionList :: [Expression] -> IO [ObjectRef]-makeExpressionList [] = return []-makeExpressionList (expr:exprs) = do- obj <- makeExpression expr- objs <- makeExpressionList exprs- return (obj:objs)- -makeClosure :: Environment -> Expression -> IO ObjectRef-makeClosure env expr = newIORef (Closure env expr)- -makeClosureList :: Environment -> [Expression] -> IO [ObjectRef]-makeClosureList _ [] = return []-makeClosureList env (expr:exprs) = do- obj <- makeClosure env expr- objs <- makeClosureList env exprs- return (obj:objs)--makeClosureInnerVals :: Environment -> [InnerExp] -> IO [InnerValue]-makeClosureInnerVals _ [] = return []-makeClosureInnerVals env (ElementExp expr : rest) = do- objRef <- makeClosure env expr- innerValRefs <- makeClosureInnerVals env rest- return (Element objRef : innerValRefs)-makeClosureInnerVals env (SubCollectionExp expr : rest) = do - objRef <- makeClosure env expr- innerValRefs <- makeClosureInnerVals env rest- return (SubCollection objRef : innerValRefs)--makeDestructInfo :: Environment -> DestructInfoExp -> IO DestructInfo-makeDestructInfo _ [] = return []-makeDestructInfo env ((cons, typeExp, dcs):deconsInfoExp) = do- typeObjRef <- makeClosure env typeExp- let dcs2 = map (\(pPat, expr) -> (env, pPat, expr)) dcs- deconsInfo <- makeDestructInfo env deconsInfoExp- return ((cons, typeObjRef, dcs2):deconsInfo)--makeFrameHelper :: [FunPat] -> [ObjectRef] -> IOThrowsError Frame-makeFrameHelper fpats objRefs =- case (fpats, objRefs) of- ([], []) -> return []- ((fpat:fps), (objRef:ivrs)) -> do frame1 <- makeFrame fpat objRef- frame2 <- makeFrameHelper fps ivrs- return (frame1 ++ frame2)- (_, _) -> throwError (Default "invalid number of argument")- -makeFrame :: FunPat -> ObjectRef -> IOThrowsError Frame-makeFrame (FunPatVar name) objRef = do- return [((name, []), objRef)]-makeFrame (FunPatTuple fpats) objRef = do- val <- cEval1 objRef- case val of- Tuple objRefs -> do makeFrameHelper fpats objRefs- _ -> makeFrameHelper fpats [objRef]--makeRecursiveFrameHelper :: Environment -> Frame -> Frame -> IO ()-makeRecursiveFrameHelper _ _ [] = return ()-makeRecursiveFrameHelper env newFrame ((_, objRef):assocs) = do- obj <- readIORef objRef- case obj of- (Closure _ expr) -> writeIORef objRef (Closure (newFrame:env) expr)- makeRecursiveFrameHelper env newFrame assocs--evalVariableList :: Environment -> [(String, [Expression])] -> IOThrowsError [(String, [Integer])]-evalVariableList _ [] = return []-evalVariableList env ((name,numExprs):rest) = do- numVals <- evalList env numExprs- let nums = integerValListToIntegerList numVals- vars <- evalVariableList env rest- return ((name,nums):vars)- -makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame-makeRecursiveFrame env bind = do- vars <- evalVariableList env (map fst bind)- let exprs = map snd bind- objRefs <- liftIO (makeClosureList [] exprs)- let newFrame = zip vars objRefs- liftIO (makeRecursiveFrameHelper env newFrame newFrame)- return newFrame--makeTopFrame :: Definitions -> IOThrowsError Frame-makeTopFrame defsRef = do- defs <- liftIO (readIORef defsRef)- makeRecursiveFrame [] defs------- InnerExp----valListToObjRefList :: [Value] -> IO [ObjectRef]-valListToObjRefList [] = return []-valListToObjRefList (val:vals) = do- objRef <- newIORef (Value val)- objRefs <- valListToObjRefList vals- return (objRef:objRefs)--objRefListToInnerVals :: [ObjectRef] -> IO [InnerValue]-objRefListToInnerVals [] = return []-objRefListToInnerVals (objRef:objRefs) = do- innerVals <- objRefListToInnerVals objRefs- return ((Element objRef):innerVals)- -innerValueListToObjRefList :: [InnerValue] -> IOThrowsError [ObjectRef]-innerValueListToObjRefList [] = return []-innerValueListToObjRefList (Element eRef:rest) = do- restRefs <- innerValueListToObjRefList rest- return (eRef:restRefs)-innerValueListToObjRefList (SubCollection subRef:rest) = do- subVal <- cEval1 subRef- case subVal of- Collection inners -> innerValueListToObjRefList (inners ++ rest)--innerValueListToValueList :: [InnerValue] -> IOThrowsError [Value]-innerValueListToValueList innerVals = do- objRefs <- innerValueListToObjRefList innerVals- cEvalList objRefs- -tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]-tupleToObjRefList objRef = do- val <- cEval1 objRef- case val of- Tuple objRefs -> return objRefs- val -> return [objRef]--tupleToValueList :: Value -> IOThrowsError [Value]-tupleToValueList (Tuple []) = return []-tupleToValueList (Tuple objRefs) = cEvalList objRefs-tupleToValueList val = return [val]--tupleObjRefListToListOfList :: [ObjectRef] -> IOThrowsError [[ObjectRef]]-tupleObjRefListToListOfList [] = return []-tupleObjRefListToListOfList (objRef:objRefs) = do- objRefs2 <- tupleToObjRefList objRef- objRefss2 <- tupleObjRefListToListOfList objRefs- return (objRefs2:objRefss2)--makeObjRefList :: [Value] -> IO [ObjectRef]-makeObjRefList [] = return []-makeObjRefList (val:vals) = do- objRef <- newIORef (Value val)- objRefs <- makeObjRefList vals- return (objRef:objRefs)--makeTupleFromValueList :: [Value] -> IO Value-makeTupleFromValueList vals = do- objRefs <- makeObjRefList vals- return (Tuple objRefs)--collectionObjToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]-collectionObjToObjRefList objRef = do- val <- cEval1 objRef- collectionToObjRefList val--collectionToObjRefList :: Value -> IOThrowsError [ObjectRef]-collectionToObjRefList (Collection innerVals) = innerValueListToObjRefList innerVals-collectionToObjRefList _ = throwError (Default "collectionObjToObjRefList : not a collection")--charCollectionToString :: Value -> IOThrowsError [Char]-charCollectionToString (Collection []) = return []-charCollectionToString (Collection (Element eRef : rest)) = do- eObj <- liftIO (readIORef eRef)- restStr <- charCollectionToString (Collection rest)- case eObj of- Value (Character c) -> return (c : restStr)- _ -> throwError (Default "charCollectionToString : not char collection")--makeCollectionFromValueList :: [Value] -> IO Value-makeCollectionFromValueList vals =- let loop vals2 = case vals2 of- [] -> return []- (val:rest) -> do objRef <- newIORef (Value val)- restRefs <- loop rest- return ((Element objRef):restRefs) in- do innerVals <- loop vals- return (Collection innerVals)--integerValListToIntegerList :: [Value] -> [Integer]-integerValListToIntegerList [] = []-integerValListToIntegerList ((Integer n):vals) = n:(integerValListToIntegerList vals)- ------ Parser-----lexer = P.makeTokenParser haskellDef--charLiteral = P.charLiteral lexer-stringLiteral = P.stringLiteral lexer-integer = P.integer lexer-float = P.float lexer-parens = P.parens lexer-angles = P.angles lexer-brackets = P.brackets lexer-braces = P.braces lexer--headSymbol :: Parser Char-headSymbol = oneOf "+-*/=:"--restSymbol :: Parser Char-restSymbol = oneOf "!?+-*/=:"--word :: Parser String-word = do first <- (letter <|> headSymbol)- rest <- many (letter <|> digit <|> restSymbol)- return (first:rest)--spaces :: Parser ()-spaces = skipMany (oneOf " \n\t")- -spaces1 :: Parser ()-spaces1 = skipMany1 (oneOf " \n\t")- -parseTopExpression :: Parser TopExpression-parseTopExpression = do spaces- parens (do try (string "define")- spaces- char '$'- name <- word- nums <- parseIndexNums- spaces- expr <- parseExpression- return (Define name nums expr)- <|> do try (string "test")- spaces- expr <- parseExpression- spaces- return (Test expr)- <|> do try (string "execute")- return Execute- <|> do try (string "load-file")- spaces- filename <- stringLiteral- spaces- return (LoadFile filename)- <|> do try (string "load")- spaces- filename <- stringLiteral- spaces- return (Load filename)- ) <?> "top expression"--parseExpression :: Parser Expression-parseExpression = do ws <- word- nums <- parseIndexNums- return (VariableExp ws nums)- <|> do c <- charLiteral- return (CharacterExp c)- <|> do str <- stringLiteral- return (StringExp str)- <|> do d <- try float- return (DoubleExp d)- <|> do n <- try integer- return (IntegerExp n)- <|> do try (do char '$'- ws <- word- nums <- parseIndexNums- return (PatVarExp ws nums))- <|> do try (do char '$'- char '~'- expr <- parseExpression- return (PatVarOmitExp expr))- <|> do try (do char '#'- ws <- word- nums <- parseIndexNums- return (SymbolExp ws nums))- <|> do char '~'- expr <- parseExpression- return (OmitExp expr)- <|> do char '_'- return WildCardExp- <|> do char '!'- expr <- parseExpression- return (CutPatExp expr)- <|> do char '^'- expr <- parseExpression- return (NotPatExp expr)- <|> do char ','- expr <- parseExpression- return (PredPatExp "equal?" [expr])- <|> angles (do c <- word- spaces- vs <- sepEndBy parseExpression spaces- return (InductiveDataExp c vs))- <|> brackets (do vs <- sepEndBy parseInnerExp spaces- return (TupleExp vs))- <|> braces (do vs <- sepEndBy parseInnerExp spaces- return (CollectionExp vs))- <|> parens (do try (do char '&'- spaces1)- exprs <- sepEndBy parseExpression spaces- return (AndPatExp exprs)- <|> do try (do char '|'- spaces1)- exprs <- sepEndBy parseExpression spaces- return (OrPatExp exprs)- <|> do try (do char '?'- spaces1)- name <- word- spaces1- exprs <- sepEndBy parseExpression spaces- return (PredPatExp name exprs)- <|> do try (do string "lambda"- spaces1)- args <- parseFunPat- spaces- body <- parseExpression- spaces- return (FunctionExp args body)- <|> do try (do string "macro"- spaces1)- args <-brackets (do args2 <- sepEndBy (do char '$'- name <- word- return name)- spaces- return args2)- spaces- body <- parseExpression- spaces- return (MacroExp args body)- <|> do try (do string "do"- spaces1)- bind <- parseBind- spaces- body <- parseExpression- spaces- return (DoExp bind body)- <|> do try (do string "let"- spaces1)- bind <- parseRecursiveBind- spaces- body <- parseExpression- spaces- return (LetExp bind body)- <|> do try (do string "loop"- spaces1)- spaces- var1 <- parseExpression- spaces- var2 <- parseExpression- spaces- range <- parseExpression- spaces- body1 <- parseExpression- spaces- body2 <- parseExpression- spaces- return (LoopExp var1 var2 range body1 body2)- <|> do try (do string "type"- spaces1)- bind <- parseRecursiveBind- return (TypeExp bind)- <|> do try (do string "type-ref"- spaces1)- typ <- parseExpression- spaces- name <- word- spaces- return (TypeRefExp typ name)- <|> do try (do string "destructor"- spaces1)- deconsInfo <- parseDestructInfoExp- spaces- return (DestructorExp deconsInfo)- <|> do try (do string "match"- spaces1)- tgt <- parseExpression- spaces- typ <- parseExpression- spaces- clss <- braces (sepEndBy parseMatchClause spaces)- return (MatchExp tgt typ clss)- <|> do try (do string "match-all"- spaces1)- tgt <- parseExpression- spaces- typ <- parseExpression- spaces- cls <- parseMatchClause- spaces- return (MatchAllExp tgt typ cls)- <|> do try (do string "match-max"- spaces1)- tgt <- parseExpression- spaces- typ <- parseExpression- spaces- cls <- parseMatchMaxClause- spaces- return (MatchMaxExp tgt typ cls)- <|> do try (do string "apply"- spaces1)- fn <- parseExpression- spaces- args <- parseExpression- spaces- return (ApplyExp fn args)- <|> do fn <- parseExpression- spaces- args <- sepEndBy parseExpression spaces- return (ApplyListExp fn args))--parseIndexNums :: Parser [Expression]-parseIndexNums = do try (do char '_'- n <- parseExpression- ns <- parseIndexNums- return (n:ns))- <|> do return []- -parseInnerExp :: Parser InnerExp-parseInnerExp = do v <- parseExpression- return (ElementExp v)- <|> do char '@'- v <- parseExpression- return (SubCollectionExp v)--parseFunPat :: Parser FunPat-parseFunPat = do char '$'- name <- word- return (FunPatVar name)- <|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces))- case fpats of- [fpat] -> return fpat- _ -> return (FunPatTuple fpats))- -parseBind :: Parser Bind-parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat- spaces- expr <- parseExpression- return (fpat, expr)))- spaces- return bs)- -parseRecursiveBind :: Parser RecursiveBind-parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$'- var <- word- nums <- parseIndexNums- spaces- expr <- parseExpression- return ((var,nums),expr)))- spaces- return bs)--parseDestructInfoExp :: Parser DestructInfoExp-parseDestructInfoExp = braces (sepEndBy parseDestructClause spaces)--parseDestructClause :: Parser (String, Expression, [(PrimePat, Expression)])-parseDestructClause = brackets (do patCons <- word- spaces- typExpr <- parseExpression- spaces- dc2s <- braces (sepEndBy parseDestructClause2 spaces)- spaces- return (patCons, typExpr, dc2s))--parseDestructClause2 :: Parser (PrimePat, Expression)-parseDestructClause2 = brackets (do datPat <- parsePrimePat- spaces- expr <- parseExpression- spaces- return (datPat, expr))--parsePrimePat :: Parser PrimePat-parsePrimePat = do char '_'- return PrimeWildCard- <|> do c <- try charLiteral- return (PrimePatCharacter c)- <|> do d <- try float- return (PrimePatDouble d)- <|> do n <- try integer- return (PrimePatInteger n)- <|> do char '$'- name <- word- return (PrimePatVar name)- <|> angles (do c <- word- spaces- ps <- sepEndBy parsePrimePat spaces- return (InductivePrimePat c ps))- <|> try (do char '{'- spaces- char '}'- return EmptyPat)- <|> try (do char '{'- spaces- a <- parsePrimePat- spaces- char '.'- b <- parsePrimePat- char '}'- return (ConsPat a b))- <|> try (do char '{'- spaces- char '.'- a <- parsePrimePat- spaces- b <- parsePrimePat- char '}'- return (SnocPat a b))- -parseMatchClause :: Parser MatchClause-parseMatchClause = brackets (do pat <- parseExpression- spaces- body <- parseExpression- return (MatchClause pat body))--parseMatchMaxClause :: Parser MatchMaxClause-parseMatchMaxClause = brackets (do pat <- parseExpression- spaces- expr <- parseExpression- spaces- body <- parseExpression- return (MatchMaxClause pat expr body))------- Show----unwordsList :: Show a => [a] -> String-unwordsList = unwords . map show--unwordsNums :: Show a => [a] -> String-unwordsNums [] = ""-unwordsNums (n:ns) = "_" ++ show n ++ unwordsNums ns--showTopExpression :: TopExpression -> String-showTopExpression (Define name nums expr) = "(define $" ++ name ++ unwordsNums nums ++ " " ++ show expr ++ ")"-showTopExpression (Test expr) = "(test " ++ show expr ++ ")"-showTopExpression (Load expr) = "(load " ++ show expr ++ ")"-showTopExpression (LoadFile expr) = "(load-file " ++ show expr ++ ")"-showTopExpression Execute = "(execute)"--instance Show TopExpression where show = showTopExpression--showExpression :: Expression -> String-showExpression (CharacterExp c) = "'" ++ show c ++ "'"-showExpression (StringExp s) = "\"" ++ show s ++ "\""-showExpression (IntegerExp n) = show n-showExpression (VariableExp name nums) = name ++ unwordsNums nums-showExpression (SymbolExp name nums) = "#" ++ name ++ unwordsNums nums-showExpression (OmitExp expr) = "~" ++ showExpression expr-showExpression (InductiveDataExp s []) = "<" ++ s ++ ">"-showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">"-showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]"-showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}"-showExpression WildCardExp = "_"-showExpression (PatVarExp name nums) = "$" ++ name ++ unwordsNums nums-showExpression (PatVarOmitExp expr) = "$~" ++ showExpression expr-showExpression (CutPatExp p) = "!" ++ show p-showExpression (NotPatExp p) = "^" ++ show p-showExpression (AndPatExp ps) = "(& " ++ unwordsList ps ++ ")"-showExpression (OrPatExp ps) = "(| " ++ unwordsList ps ++ ")"-showExpression (PredPatExp name ps) = "(? " ++ name ++ " " ++ unwordsList ps ++ ")"-showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"-showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")"-showExpression (LoopExp var1 var2 range body1 body2) = "(loop" ++ " " ++ show var1 ++ " " ++ show var2 ++ " " ++ show range ++ " " ++ show body1 ++ " " ++ show body2 ++ ")"-showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")"-showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")"-showExpression (DestructorExp deconsInfoExp) = "(destructor " ++ showDestructInfoExp deconsInfoExp ++ ")"-showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})"-showExpression (MatchAllExp tgt typ cls) = "(match-all " ++ show tgt ++ " " ++ show typ ++ " " ++ show cls ++ ")"-showExpression (ApplyListExp fn args) = "(apply " ++ show fn ++ " " ++ unwordsList args ++ ")"--instance Show Expression where show = showExpression--showInnerExp :: InnerExp -> String-showInnerExp (ElementExp v) = show v-showInnerExp (SubCollectionExp v) = "@" ++ show v--instance Show InnerExp where show = showInnerExp--showRecursiveBind :: RecursiveBind -> String-showRecursiveBind [] = "{}"-showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}"--showRecursiveBindHelper :: ((String, [Expression]), Expression) -> String-showRecursiveBindHelper ((name,nums),expr) = "[$" ++ name ++ unwordsNums nums ++ " " ++ show expr ++ "]"--showFunPat :: FunPat -> String-showFunPat (FunPatVar name) = "$" ++ name-showFunPat (FunPatTuple []) = "[]"-showFunPat (FunPatTuple fpats) = "[" ++ unwordsList fpats ++ "]"--instance Show FunPat where show = showFunPat--showDestructInfoExp :: DestructInfoExp -> String-showDestructInfoExp dcs = "{" ++ unwords (map showDestructClause dcs) ++ "}"--showDestructClause :: (String, Expression, [(PrimePat, Expression)]) -> String-showDestructClause (cons, typs, dc2s) = "[" ++ cons ++ " " ++ show typs ++ " {" ++ unwords (map showDestructClause2 dc2s) ++ "})"--showDestructClause2 :: (PrimePat, Expression) -> String-showDestructClause2 (pat, expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"--showPrimePat :: PrimePat -> String-showPrimePat PrimeWildCard = "_"-showPrimePat (PrimePatVar name) = "$" ++ name-showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">"-showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">"-showPrimePat EmptyPat = "{}"-showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}"-showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}"--instance Show PrimePat where show = showPrimePat--showMatchClause :: MatchClause -> String-showMatchClause (MatchClause pat expr) = "[" ++ show pat ++ " " ++ show expr ++ "]"--instance Show MatchClause where show = showMatchClause------- read and show Value----readValue :: String -> IOThrowsError Value-readValue exprStr = do- expr <- readExpression exprStr- expressionToValue expr--readExpression :: String -> IOThrowsError Expression-readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr)--expressionToValue :: Expression -> IOThrowsError Value-expressionToValue (CharacterExp c) = return (Character c)-expressionToValue (StringExp str) = do- val <- liftIO (makeCollectionFromValueList (map Character str))- return val-expressionToValue (IntegerExp n) = return (Integer n)-expressionToValue (DoubleExp d) = return (Double d)-expressionToValue (InductiveDataExp con exprs) = do- vals <- expressionToValueMap exprs- objRefs <- liftIO (valListToObjRefList vals)- return (InductiveData con objRefs)-expressionToValue (TupleExp innerExps) = do- innerVals <- innerExpToInnerValueMap innerExps- vals <- innerValueListToValueList innerVals- case vals of- [val] -> return val- _ -> do objRefs <- liftIO $ makeObjRefList vals- return (Tuple objRefs)-expressionToValue (CollectionExp innerExps) = do- innerVals <- innerExpToInnerValueMap innerExps- return (Collection innerVals)-expressionToValue expr = throwError (WithExpression "You should give a value as an input of read." expr)--expressionToValueMap :: [Expression] -> IOThrowsError [Value]-expressionToValueMap [] = return []-expressionToValueMap (expr:exprs) = do- val <- expressionToValue expr- vals <- expressionToValueMap exprs- return (val:vals)--innerExpToInnerValueMap :: [InnerExp] -> IOThrowsError [InnerValue]-innerExpToInnerValueMap [] = return []-innerExpToInnerValueMap (ElementExp expr:rest) = do- val <- expressionToValue expr- objRef <- liftIO (newIORef (Value val))- innerVals <- innerExpToInnerValueMap rest- return (Element objRef:innerVals)-innerExpToInnerValueMap (SubCollectionExp expr:rest) = do- val <- expressionToValue expr- objRef <- liftIO (newIORef (Value val))- innerVals <- innerExpToInnerValueMap rest- return (SubCollection objRef:innerVals)- -showValue :: Value -> IOThrowsError String-showValue (World _) = return "#<world>"-showValue (Character c) = return (show c)-showValue (Integer n) = return (show n)-showValue (Double d) = return (show d)-showValue (InductiveData cons []) = do- return ("<" ++ cons ++ ">")-showValue (InductiveData cons objRefs) = do- vals <- cEvalList objRefs- str <- unwordsVals vals- return ("<" ++ cons ++ " " ++ str ++ ">")-showValue (Tuple []) = do- return ("[]")-showValue (Tuple objRefs) = do- vals <- cEvalList objRefs- str <- unwordsVals vals- return ("[" ++ str ++ "]")-showValue (Collection []) = do- return ("{}")-showValue (Collection innerVals) = do- vals <- innerValueListToValueList innerVals- str <- unwordsVals vals- return ("{" ++ str ++ "}")-showValue WildCard = return "_"-showValue (PatVar name nums) = return ("$" ++ name ++ unwordsNums nums)-showValue (CutPat _) = return "#<cut-pat>"-showValue (AndPat _) = return "#<and-pat>"-showValue (OrPat _) = return "#<or-pat>"-showValue (PredPat _ _) = return "#<pred-pat>"-showValue (Function _ _ _) = do- return "#<function>"-showValue (Loop _ _ _ _ _) = return "#<loop>"-showValue (Type _) = do- return "#<type>"-showValue (DestructorFunction _) = do- return "#<destructor-function>"-showValue (BuiltinFunction _) = do- return "#<builtin-function>"--unwordsVals :: [Value] -> IOThrowsError String-unwordsVals [] = return ""-unwordsVals (val:vals) = do- s1 <- showValue val- s2 <- unwordsValsHelper vals- return (s1 ++ s2)- -unwordsValsHelper :: [Value] -> IOThrowsError String-unwordsValsHelper [] = return ""-unwordsValsHelper (val:vals) = do- s1 <- showValue val- s2 <- unwordsValsHelper vals- return (" " ++ s1 ++ s2)--showObjectRef :: ObjectRef -> IO String-showObjectRef objRef = do- obj <- readIORef objRef- case obj of--- Closure env expr -> do envStr <- liftIO (showEnv env)--- return ("(Closure " ++ envStr ++ " " ++ (show expr) ++ ")")- Closure _ _ -> return "#<closure>"- Value _ -> return "#<value>"--showEnv :: Environment -> IO String-showEnv [] = return "empty-env"-showEnv (frame:_) = do frameStr <- showFrame frame- return ("(Env " ++ frameStr ++ " : " ++ "..." ++ ")")---showEnv (frame1:(frame2:_)) = do frameStr1 <- showFrame frame1--- frameStr2 <- showFrame frame2--- return ("(Env " ++ frameStr1 ++ " : " ++ frameStr2 ++ " : ...)")--showFrame :: Frame -> IO String-showFrame [] = return "[]"-showFrame (((var,nums),objRef):frame) = do- objRefStr <- showObjectRef objRef- frameStr <- showFrame frame- return ("(" ++ var ++ unwordsNums nums ++"," ++ objRefStr ++"):" ++ frameStr)------- Evaluation----eval1Variable :: Environment -> String -> [Integer] -> IOThrowsError Value-eval1Variable env name nums =- let maybeObjRef = getValue env (name,nums) in- case maybeObjRef of- Just objRef -> do val <- cEval1 objRef- case val of- Loop _ _ _ _ _ -> eval1Loop env val- Expression expr -> eval1 env expr- _ -> return val- Nothing -> let mBuiltinFn = getBuiltin name in- case mBuiltinFn of- Just builtinFn -> return (BuiltinFunction builtinFn)- Nothing -> throwError (UnboundVariable name nums)--eval1 :: Environment -> Expression -> IOThrowsError Value-eval1 _ (CharacterExp c) = return (Character c)-eval1 _ (StringExp str) = do- val <- liftIO (makeCollectionFromValueList (map Character str))- return val-eval1 _ (IntegerExp n) = return (Integer n)-eval1 _ (DoubleExp d) = return (Double d)-eval1 env (VariableExp name numExprs) = do- numVals <- evalList env numExprs- let nums = integerValListToIntegerList numVals- eval1Variable env name nums-eval1 env (SymbolExp name numExprs) = do- numVals <- evalList env numExprs- let nums = integerValListToIntegerList numVals- return (Symbol name nums)-eval1 env (OmitExp expr) = do- val <- eval1 env expr- case val of- Symbol name nums -> eval1Variable env name nums- _ -> throwError (Default "argument of omit is not symbol")-eval1 env (InductiveDataExp con exprs) = do- objRefs <- liftIO (makeClosureList env exprs)- return (InductiveData con objRefs)-eval1 env (TupleExp innerExps) = do- innerVals <- liftIO (makeClosureInnerVals env innerExps)- objRefs <- innerValueListToObjRefList innerVals- case objRefs of- [objRef] -> cEval1 objRef- _ -> return (Tuple objRefs)-eval1 env (CollectionExp innerExps) = do- innerVals <- liftIO (makeClosureInnerVals env innerExps)- return (Collection innerVals)-eval1 _ WildCardExp = return WildCard-eval1 env (PatVarExp name numExprs) = do- numVals <- evalList env numExprs- return (PatVar name (integerValListToIntegerList numVals))-eval1 env (PatVarOmitExp expr) = do- val <- eval1 env expr- case val of- Symbol name nums -> return (PatVar name nums)- _ -> throwError (Default "argument of omit is not symbol")-eval1 env (PredPatExp name exprs) = do- objRefs <- liftIO (makeClosureList env exprs)- return (PredPat name objRefs)-eval1 env (NotPatExp expr) = do- objRef <- liftIO (makeClosure env expr)- return (NotPat objRef)-eval1 env (CutPatExp expr) = do- objRef <- liftIO (makeClosure env expr)- return (CutPat objRef)-eval1 env (AndPatExp exprs) = do- objRefs <- liftIO (makeClosureList env exprs)- return (AndPat objRefs)-eval1 env (OrPatExp exprs) = do- objRefs <- liftIO (makeClosureList env exprs)- return (OrPat objRefs)-eval1 env (FunctionExp args body) = return (Function env args body)-eval1 _ (MacroExp args body) = return (Macro args body)-eval1 env (DoExp [] body) = eval1 env body-eval1 env (DoExp ((fpat,expr):assocs) body) = do- objRef <- liftIO (makeClosure env expr)- frame <- makeFrame fpat objRef- eval1 (frame:env) (DoExp assocs body)-eval1 env (LetExp bind body) = do- frame <- makeRecursiveFrame env bind- objRef <- liftIO (newIORef (Closure (frame:env) body))- cEval1 objRef-eval1 env (LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do- range <- liftIO (makeClosure env rangeExpr)- eval1Loop env (Loop var1 var2 range expr1 expr2)-eval1 env (TypeExp bind) = do- frame <- makeRecursiveFrame env bind- return (Type frame)-eval1 env expr@(TypeRefExp typExp name) = do- typVal <- eval1 env typExp- case typVal of- (Type frame) -> let mObjRef = getValueFromFrame frame (name,[]) in- case mObjRef of- Nothing -> throwError (WithExpression ("no method in type" ++ name) expr)- Just objRef -> do val <- cEval1 objRef- return val- _ -> throwError (WithExpression "first arg of typeref is not type" expr)-eval1 env (DestructorExp deconsInfoExp) = do- deconsInfo <- liftIO (makeDestructInfo env deconsInfoExp)- return (DestructorFunction deconsInfo)-eval1 env (MatchExp tgtExp typExp mCs) = do- typObj <- liftIO (makeClosure env typExp)- tgtObj <- liftIO (makeClosure env tgtExp)- evalMatchExp env typObj tgtObj mCs-eval1 env (MatchAllExp tgtExp typExp mC) = do- typObj <- liftIO (makeClosure env typExp)- tgtObj <- liftIO (makeClosure env tgtExp)- evalMatchAllExp env typObj tgtObj mC -eval1 env (MatchMaxExp tgtExp typExp mC) = do- typObj <- liftIO (makeClosure env typExp)- tgtObj <- liftIO (makeClosure env tgtExp)- evalMatchMaxExp env typObj tgtObj mC -eval1 env expr@(ApplyListExp fnExp argsExps) = do- fnVal <- eval1 env fnExp- case fnVal of- BuiltinFunction builtinFn -> do argsObjRefs <- liftIO (makeClosureList env argsExps)- argsVals <- cEvalList argsObjRefs- builtinFn argsVals- Function funEnv fpat body -> do argsObjRefs <- liftIO (makeClosureList env argsExps)- arg <- liftIO (newIORef (Value (Tuple argsObjRefs)))- frame <- makeFrame fpat arg- objRef <- liftIO (makeClosure (frame:funEnv) body)- cEval1 objRef- Macro vars body -> let body2 = expandMacro (zip vars argsExps) body in- eval1 env body2- _ -> throwError (WithExpression "applying non-functional object" expr)--type MFrame = [(String, Expression)]--searchMFrame :: MFrame -> String -> Maybe Expression-searchMFrame [] _ = Nothing-searchMFrame ((name,expr):rest) varName = if name == varName- then Just expr- else searchMFrame rest varName--expandMacro :: MFrame -> Expression -> Expression-expandMacro mf (VariableExp name []) =- case searchMFrame mf name of- Nothing -> VariableExp name []- Just expr -> expr-expandMacro mf (VariableExp name numExprs) = VariableExp name (mapExpandMacro mf numExprs)-expandMacro mf (SymbolExp name numExprs) = SymbolExp name (mapExpandMacro mf numExprs)-expandMacro mf (OmitExp expr) = OmitExp (expandMacro mf expr)-expandMacro mf (InductiveDataExp cons exprs) = InductiveDataExp cons (mapExpandMacro mf exprs)-expandMacro mf (TupleExp innerExprs) = TupleExp (mapExpandMacroInnerExp mf innerExprs)-expandMacro mf (CollectionExp innerExprs) = CollectionExp (mapExpandMacroInnerExp mf innerExprs)-expandMacro mf (PatVarExp name numExprs) = PatVarExp name (mapExpandMacro mf numExprs)-expandMacro mf (PatVarOmitExp expr) = PatVarOmitExp (expandMacro mf expr)-expandMacro mf (CutPatExp expr) = CutPatExp (expandMacro mf expr)-expandMacro mf (NotPatExp expr) = NotPatExp (expandMacro mf expr)-expandMacro mf (AndPatExp exprs) = AndPatExp (mapExpandMacro mf exprs)-expandMacro mf (OrPatExp exprs) = OrPatExp (mapExpandMacro mf exprs)-expandMacro mf (PredPatExp name exprs) = PredPatExp name (mapExpandMacro mf exprs)-expandMacro mf (FunctionExp fpat body) = FunctionExp fpat (expandMacro mf body)-expandMacro mf (MacroExp vars body) = MacroExp vars (expandMacro mf body)-expandMacro mf (DoExp bind body) = undefined-expandMacro mf (LetExp bind body) = undefined-expandMacro mf (LoopExp lVar iVar rangeExp inExp outExp) =- LoopExp (expandMacro mf lVar) (expandMacro mf iVar) (expandMacro mf rangeExp) (expandMacro mf inExp) (expandMacro mf outExp)-expandMacro mf (TypeExp bind) = undefined-expandMacro mf (TypeRefExp tExp name) = TypeRefExp (expandMacro mf tExp) name-expandMacro mf (DestructorExp deconsInfo) = undefined-expandMacro mf (MatchExp tgtExp typExp clsExps) = MatchExp (expandMacro mf tgtExp) (expandMacro mf typExp) (mapExpandMacroMatchClause mf clsExps)-expandMacro mf (MatchAllExp tgtExp typExp clsExp) = MatchAllExp (expandMacro mf tgtExp) (expandMacro mf typExp) (expandMacroMatchClause mf clsExp)-expandMacro mf (ApplyExp fnExp argsExp) = ApplyExp (expandMacro mf fnExp) (expandMacro mf argsExp)-expandMacro mf (ApplyListExp fnExp argsExps) = ApplyListExp (expandMacro mf fnExp) (mapExpandMacro mf argsExps)-expandMacro _ expr = expr--mapExpandMacro :: MFrame -> [Expression] -> [Expression]-mapExpandMacro mf exprs = map (\expr -> expandMacro mf expr) exprs--expandMacroMatchClause :: MFrame -> MatchClause -> MatchClause-expandMacroMatchClause mf (MatchClause patExp body) = MatchClause (expandMacro mf patExp) (expandMacro mf body)--mapExpandMacroMatchClause :: MFrame -> [MatchClause] -> [MatchClause]-mapExpandMacroMatchClause mf mClss = map (\mCls -> expandMacroMatchClause mf mCls) mClss--mapExpandMacroInnerExp :: MFrame -> [InnerExp] -> [InnerExp]-mapExpandMacroInnerExp mf innerExps = map (\innerExp -> expandMacroInnerExp mf innerExp) innerExps--expandMacroInnerExp :: MFrame -> InnerExp -> InnerExp-expandMacroInnerExp mf (ElementExp expr) = ElementExp (expandMacro mf expr)-expandMacroInnerExp mf (SubCollectionExp expr) = SubCollectionExp (expandMacro mf expr)--eval :: Environment -> Expression -> IOThrowsError Value-eval env expr = do- objRef <- liftIO (makeClosure env expr)- val <- cEval objRef- return val--evalList :: Environment -> [Expression] -> IOThrowsError [Value]-evalList _ [] = return []-evalList env (expr:exprs) = do- val <- eval env expr- vals <- evalList env exprs- return (val:vals)- -cEval1 :: ObjectRef -> IOThrowsError Value-cEval1 objRef = do- obj <- liftIO (readIORef objRef)- case obj of- Closure env expr ->- do val <- eval1 env expr- liftIO (writeIORef objRef (Value val))- return val- Value (Tuple [objRef2]) ->- do val <- cEval1 objRef2- liftIO (writeIORef objRef (Value val))- return val- Value val -> return val--cEval :: ObjectRef -> IOThrowsError Value-cEval objRef = do- val1 <- cEval1 objRef- evalValue val1- -cEvalList :: [ObjectRef] -> IOThrowsError [Value]-cEvalList [] = return []-cEvalList (objRef:objRefs) = do- val <- cEval objRef- vals <- cEvalList objRefs- return (val:vals)--evalValue :: Value -> IOThrowsError Value-evalValue (InductiveData cons objRefs) = do- cEvalList objRefs- return (InductiveData cons objRefs)-evalValue (Tuple objRefs) = do- cEvalList objRefs- return (Tuple objRefs)-evalValue (Collection innerVals) = do- evalInnerVals innerVals- return (Collection innerVals)-evalValue val = return val- -eval1Loop :: Environment -> Value -> IOThrowsError Value-eval1Loop env (Loop var1 var2 range expr1 expr2) = do- rVal <- cEval1 range- b <- isEmptyCollection rVal- if b- then do eval1 env expr2- else do (carObjRef,cdrObjRef) <- consDestruct rVal- loopObjRef <- liftIO (newIORef (Value (Loop var1 var2 cdrObjRef expr1 expr2)))- eval1 ([((var1,[]),loopObjRef),((var2,[]),carObjRef)]:env) expr1-eval1Loop _ _ = throwError (Default "eval1Loop")--evalInnerVals :: [InnerValue] -> IOThrowsError ()-evalInnerVals [] = return ()-evalInnerVals (Element objRef : rest) = do- cEval objRef- evalInnerVals rest-evalInnerVals (SubCollection objRef : rest) = do- cEval objRef- evalInnerVals rest--evalMatchExp :: Environment -> ObjectRef -> ObjectRef -> [MatchClause] -> IOThrowsError Value-evalMatchExp env typObjRef tgtObjRef (MatchClause pat expr:rest) = do- patObjRef <- liftIO (makeClosure env pat)- matchs <- patternMatch1 [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]- case matchs of- [] -> evalMatchExp env typObjRef tgtObjRef rest- (frame:_) -> do objRef <- liftIO (makeClosure (frame:env) expr)- cEval1 objRef-evalMatchExp _ _ _ _ = throwError (Default "end of match clause")--evalMatchAllExp :: Environment -> ObjectRef -> ObjectRef -> MatchClause -> IOThrowsError Value-evalMatchAllExp env typObjRef tgtObjRef (MatchClause pat expr) = do- patObjRef <- liftIO (makeClosure env pat)- matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]- innerVals <- evalMatchAllExpHelper env matchs expr- retObjRef <- liftIO (newIORef (Value (Collection innerVals)))- cEval retObjRef--evalMatchAllExpHelper :: Environment -> [Frame] -> Expression -> IOThrowsError [InnerValue]-evalMatchAllExpHelper _ [] _ = return []-evalMatchAllExpHelper env (frame:frames) expr = do- objRef <- liftIO (makeClosure (frame:env) expr)- rest <- evalMatchAllExpHelper env frames expr- return (Element objRef:rest)--evalMatchMaxExp :: Environment -> ObjectRef -> ObjectRef -> MatchMaxClause -> IOThrowsError Value-evalMatchMaxExp env typObjRef tgtObjRef (MatchMaxClause pat expr body) = do- patObjRef <- liftIO (makeClosure env pat)- matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]- case matchs of- [] -> throwError (Default "matchMax: no matching")- _ -> do- evallist <- mapM (\frame -> eval (frame:env) expr) matchs- let numlist = map (\val -> case val of- Integer n -> n- ) evallist- maxplace <- maxlistplace numlist- maxmatchs <- pickupnumlist matchs maxplace- innerVals <- evalMatchAllExpHelper env maxmatchs body- retObjRef <- liftIO (newIORef (Value (Collection innerVals)))- cEval retObjRef--maxlistplace :: [Integer] -> IOThrowsError [Integer]-maxlistplace [] = throwError (Default "matchMax: no number list")-maxlistplace (x:xs) =- let mhelper ls maxnumber maxplace nowplace = case ls of- [] -> return maxplace- (y:ys) -> if (y > maxnumber) - then mhelper ys y [nowplace] (nowplace + 1)- else if (y == maxnumber)- then mhelper ys maxnumber (nowplace:maxplace) (nowplace + 1)- else mhelper ys maxnumber maxplace (nowplace + 1)- in mhelper xs x [1] 2- -pickupnum :: [a] -> Integer -> IOThrowsError a-pickupnum [] _ = throwError (Default "matchMax: cannot pick up")-pickupnum (x:xs) n = if (n >= 1)- then if (n > 1)- then pickupnum xs (n - 1)- else return x- else throwError (Default "matchMax: cannot pick up")--pickupnumlist :: [a] -> [Integer] -> IOThrowsError [a] -pickupnumlist [] _ = throwError (Default "matchMax: cannot pick up")-pickupnumlist list n = - let phelper ls nl picked = case nl of- [] -> return picked- (m:ms) -> do- nowpick <- pickupnum ls m- phelper ls ms (nowpick:picked)- in phelper list n []------- Pattern Match----patternMatch1 :: [MState] -> IOThrowsError [Frame]-patternMatch1 [] = return []-patternMatch1 ((MState frame []):_) = do- return [frame]-patternMatch1 ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef):atoms)):states) = do- patObj <- liftIO (readIORef patObjRef)- case patObj of- Value (World _) -> throwError (Default "patternMatch1: not a pattern")- Value (Character _) -> throwError (Default "patternMatch1: not a pattern")- Value (Integer _) -> throwError (Default "patternMatch1: not a pattern")- Value (Double _) -> throwError (Default "patternMatch1: not a pattern")- Value (Collection _) -> throwError (Default "patternMatch1: not a pattern")- Value (Function _ _ _) -> throwError (Default "patternMatch1: not a pattern")- Value (Type _) -> throwError (Default "patternMatch1: not a pattern")- Value (DestructorFunction _) -> throwError (Default "patternMatch1: not a pattern")- Value (BuiltinFunction _) -> throwError (Default "patternMatch1: not a pattern")- Value WildCard -> patternMatch1 ((MState frame atoms):states)- Value (PatVar var nums) ->- do typVal <- cEval1 typObjRef- case typVal of- Type tf -> let mObjRef = getValueFromFrame tf ("var-match",[]) in- case mObjRef of- Nothing -> throwError (Default "no method in type: var-match")- Just fnObjRef ->- do ret <- cApply fnObjRef [tgtObjRef]- objRefs <- collectionToObjRefList ret- patternMatch1 ((map (\objRef -> (MState (((var,nums),objRef):frame)- (map (\(MAtom (PClosure bf2 pat) tgt typ) -> (MAtom (PClosure (((var,nums),objRef):bf2) pat) tgt typ))- atoms)))- objRefs) ++ states)- _ -> throwError (Default "patternMatch1: patVar not type")- Value (Tuple pats) -> - do tgts <- tupleToObjRefList tgtObjRef- typs <- tupleToObjRefList typObjRef- patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states)- Value (InductiveData con pats) ->- do typVal <- cEval1 typObjRef- case typVal of- Type tf -> let mObjRef = getValueFromFrame tf ("inductive-match",[]) in- case mObjRef of- Nothing -> throwError (Default "no method in type: var-match")- Just fnObjRef ->- do fnObj <- cEval1 fnObjRef- case fnObj of- DestructorFunction deconInfo ->- do indRet <- inductiveMatch deconInfo con tgtObjRef- case indRet of- (nTypObjRef, nTgtsObjRef) ->- do inTypObjRefs <- tupleToObjRefList nTypObjRef- inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef- inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs- patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))- pats inTgtObjRefs inTypObjRefs) ++ atoms)))- inTgtObjRefss) ++ states)- _ -> throwError (Default "patternMatch1: inductive-match is not destructor")- Value (PredPat predName pats) ->- do typVal <- cEval1 typObjRef- case typVal of- Type tf -> let mObjRef = getValueFromFrame tf (predName,[]) in- case mObjRef of- Nothing -> throwError (Default "no method in type: var-match")- Just fnObjRef ->- do ret <- cApply fnObjRef (pats ++ [tgtObjRef])- case ret of- (InductiveData "true" []) -> patternMatch1 ((MState frame atoms):states)- (InductiveData "false" []) -> patternMatch1 states- _ -> throwError (Default "patternMatch1: return value of pred-pattern is not boolean")- Value (NotPat pat) -> - do retFrames <- patternMatch [(MState frame [(MAtom (PClosure bf pat) tgtObjRef typObjRef)])]- case retFrames of- [] -> patternMatch1 ((MState frame atoms):states)- _ -> patternMatch1 states- Value (AndPat pats) ->- patternMatch1 ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states)- Value (OrPat pats) ->- patternMatch1 ((map (\pat -> (MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms)))- pats) ++ states)- Value (CutPat pat) ->- do retFrames <- patternMatch1 [(MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))]- case retFrames of- [] -> return []- _ -> do return retFrames- Closure env expr ->- do patObj2 <- eval1 (bf:env) expr- patObjRef2 <- liftIO (newIORef (Value patObj2))- patternMatch1 ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef):atoms)):states)--patternMatch :: [MState] -> IOThrowsError [Frame]-patternMatch [] = return []-patternMatch ((MState frame []):rest) = do- frames <- patternMatch rest- return (frame:frames)-patternMatch ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef):atoms)):states) = do- patObj <- liftIO (readIORef patObjRef)- case patObj of- Value (World _) -> throwError (Default "patternMatch: not a pattern")- Value (Character _) -> throwError (Default "patternMatch: not a pattern")- Value (Integer _) -> throwError (Default "patternMatch: not a pattern")- Value (Double _) -> throwError (Default "patternMatch: not a pattern")- Value (Collection _) -> throwError (Default "patternMatch: not a pattern")- Value (Function _ _ _) -> throwError (Default "patternMatch: not a pattern")- Value (Type _) -> throwError (Default "patternMatch: not a pattern")- Value (DestructorFunction _) -> throwError (Default "patternMatch: not a pattern")- Value (BuiltinFunction _) -> throwError (Default "patternMatch: not a pattern")- Value WildCard -> patternMatch ((MState frame atoms):states)- Value (PatVar var nums) ->- do typVal <- cEval1 typObjRef- case typVal of- Type tf -> let mObjRef = getValueFromFrame tf ("var-match",[]) in- case mObjRef of- Nothing -> throwError (Default "no method in type: var-match")- Just fnObjRef ->- do ret <- cApply fnObjRef [tgtObjRef]- objRefs <- collectionToObjRefList ret- patternMatch ((map (\objRef -> (MState (((var,nums),objRef):frame)- (map (\(MAtom (PClosure bf2 pat) tgt typ) -> (MAtom (PClosure (((var,nums),objRef):bf2) pat) tgt typ))- atoms)))- objRefs) ++ states)- _ -> throwError (Default "patternMatch: patVar not type")- Value (Tuple pats) -> - do tgts <- tupleToObjRefList tgtObjRef- typs <- tupleToObjRefList typObjRef- patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states)- Value (InductiveData con pats) ->- do typVal <- cEval1 typObjRef- case typVal of- Type tf -> let mObjRef = getValueFromFrame tf ("inductive-match",[]) in- case mObjRef of- Nothing -> throwError (Default "no method in type: inductive-match")- Just fnObjRef ->- do fnObj <- cEval1 fnObjRef- case fnObj of- DestructorFunction deconInfo ->- do indRet <- inductiveMatch deconInfo con tgtObjRef- case indRet of- (nTypObjRef, nTgtsObjRef) ->- do inTypObjRefs <- tupleToObjRefList nTypObjRef- inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef- inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs- patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))- pats inTgtObjRefs inTypObjRefs) ++ atoms)))- inTgtObjRefss) ++ states)- _ -> throwError (Default "patternMatch: inductive-match is not destructor")- Value (PredPat predName pats) ->- do typVal <- cEval1 typObjRef- case typVal of- Type tf -> let mObjRef = getValueFromFrame tf (predName,[]) in- case mObjRef of- Nothing -> throwError (Default "no method in type: var-match")- Just fnObjRef ->- do ret <- cApply fnObjRef (pats ++ [tgtObjRef])- case ret of- (InductiveData "true" []) -> do --liftIO $ putStrLn "egiTest11"- patternMatch ((MState frame atoms):states)- (InductiveData "false" []) -> do --liftIO $ putStrLn "egiTest12"- patternMatch states- _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean")- Value (NotPat pat) -> - do retFrames <- patternMatch [(MState frame [(MAtom (PClosure bf pat) tgtObjRef typObjRef)])]- case retFrames of- [] -> do --liftIO $ putStrLn "egiTest1"- patternMatch ((MState frame atoms):states)- _ -> do --liftIO $ putStrLn "egiTest2"- patternMatch states- Value (AndPat pats) ->- patternMatch ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states)- Value (OrPat pats) ->- patternMatch ((map (\pat -> (MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms)))- pats) ++ states)- Value (CutPat pat) ->- do retFrames <- patternMatch [(MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))]- case retFrames of- [] -> return []- _ -> do restFrames <- patternMatch states- return (retFrames ++ restFrames)- Closure env expr ->- do patObj2 <- eval1 (bf:env) expr- patObjRef2 <- liftIO (newIORef (Value patObj2))- patternMatch ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef):atoms)):states)--cApply :: ObjectRef -> [ObjectRef] -> IOThrowsError Value-cApply fnObjRef argObjRefs = do- fnVal <- cEval1 fnObjRef- case fnVal of- BuiltinFunction builtinFn -> do argVals <- cEvalList argObjRefs- retVal <- builtinFn argVals- return retVal- Function funEnv fpat body -> do objRef <- liftIO (newIORef (Value (Tuple argObjRefs)))- frame <- makeFrame fpat objRef- retObjRef <- liftIO (makeClosure (frame:funEnv) body)- retVal <- cEval1 retObjRef- return retVal- _ -> throwError (Default "cApply: not a function")--map3 :: ((a,b,c) -> d) -> [a] -> [b] -> [c] -> [d]-map3 fn [] [] [] = []-map3 fn (x:xs) (y:ys) (z:zs) = (fn (x,y,z)):(map3 fn xs ys zs)------- Inductive Match----inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef,ObjectRef)-inductiveMatch [] _ _ = throwError (Default "inductiveMatch: not matched any clauses")-inductiveMatch ((con,_,[]):rest) pcon tgtObjRefRef =- if (con == pcon)- then throwError (Default "inductiveMatch: not matched any clauses")- else inductiveMatch rest pcon tgtObjRefRef-inductiveMatch ((con,typObjRef,((env,ppat,expr):cls)):rest) pcon tgtObjRefRef =- if (con == pcon)- then do mPpmRet <- primitivePatternMatch ppat tgtObjRefRef- case mPpmRet of- Nothing -> inductiveMatch ((con,typObjRef,cls):rest) pcon tgtObjRefRef- Just ppmRet -> do ret <- liftIO (makeClosure (ppmRet:env) expr)- return (typObjRef,ret)- else inductiveMatch rest pcon tgtObjRefRef------- Primitive Pattern Match----primitivePatternMatch :: PrimePat -> ObjectRef -> IOThrowsError (Maybe Frame)-primitivePatternMatch PrimeWildCard _ = return (Just [])-primitivePatternMatch (PrimePatCharacter c) objRef = do- val <- cEval1 objRef- case val of- Character c2 -> if c == c2- then return (Just [])- else return Nothing- _ -> throwError (Default "primitive : not character to primitive character pat")-primitivePatternMatch (PrimePatInteger n) objRef = do- val <- cEval1 objRef- case val of- Integer n2 -> if n == n2- then return (Just [])- else return Nothing- _ -> throwError (Default "primitive : not integer to primitive integer pat")---primitivePatternMatch (PrimePatDouble d) objRef = do--- val <- cEval1 objRef--- case val of--- Integer d2 -> if d == d2--- then return (Just (Frame []))--- else return Nothing--- _ -> throwError (Default "primitive : not double to primitive double pat")-primitivePatternMatch (PrimePatVar name) objRef = return (Just [((name,[]), objRef)])-primitivePatternMatch (InductivePrimePat pCons pPats) objRef = do- val <- cEval1 objRef- case val of- InductiveData cons objRefs -> if pCons == cons- then primitivePatternMatchList pPats objRefs- else return Nothing- _ -> do valStr <- showValue val- throwError (Default ("primitive : not inductive value to primitive inductive pattern : " ++ valStr))-primitivePatternMatch EmptyPat objRef = do- val <- cEval1 objRef- b <- isEmptyCollection val- if b- then return (Just [])- else return Nothing-primitivePatternMatch (ConsPat carPat cdrPat) objRef = do- val <- cEval1 objRef- b <- isEmptyCollection val- if b- then return Nothing- else do (carObjRef, cdrObjRef) <- consDestruct val- mCarFrame <- primitivePatternMatch carPat carObjRef- case mCarFrame of- Nothing -> return Nothing- Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrObjRef- case mCdrFrame of- Nothing -> return Nothing- Just cdrFrame -> return (Just (carFrame ++ cdrFrame))-primitivePatternMatch (SnocPat rdcPat racPat) objRef = do- val <- cEval1 objRef- b <- isEmptyCollection val- if b- then return Nothing- else do (racObjRef, rdcObjRef) <- snocDestruct val- mRacFrame <- primitivePatternMatch racPat racObjRef- case mRacFrame of- Nothing -> return Nothing- Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcObjRef- case mRdcFrame of- Just rdcFrame -> return (Just (racFrame ++ rdcFrame))- Nothing -> return Nothing- -primitivePatternMatchList :: [PrimePat] -> [ObjectRef] -> IOThrowsError (Maybe Frame)-primitivePatternMatchList [] [] = return (Just [])-primitivePatternMatchList (pat:pats) (objRef:objRefs) = do- mFrame <- primitivePatternMatch pat objRef- case mFrame of- Nothing -> return Nothing- Just frame -> do mRestFrame <- primitivePatternMatchList pats objRefs- case mRestFrame of- Nothing -> return Nothing- Just restFrame -> return (Just (frame ++ restFrame))-primitivePatternMatchList _ _ = throwError (Default "primitivePatternMatchList : number of patterns and targets are different")--isEmptyCollection :: Value -> IOThrowsError Bool-isEmptyCollection (Collection []) = return True-isEmptyCollection (Collection (Element _:_)) = return False-isEmptyCollection (Collection (SubCollection subRef:rest)) = do- subVal <- cEval1 subRef- b <- isEmptyCollection subVal- if b- then isEmptyCollection (Collection rest)- else return False-isEmptyCollection _ = throwError (Default "isEmptyCollection : not collection")--consDestruct :: Value -> IOThrowsError (ObjectRef, ObjectRef)-consDestruct (Collection (Element eRef:rest)) = do- restRef <- liftIO (newIORef (Value (Collection rest)))- return (eRef, restRef)-consDestruct (Collection (SubCollection subRef:rest)) = do- subVal <- cEval1 subRef- b <- isEmptyCollection subVal- if b- then consDestruct (Collection rest)- else do (carRef, cdrRef) <- consDestruct subVal- cdrVal <- cEval1 cdrRef- case cdrVal of- Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest))))- return (carRef, restRef)- _ -> undefined-consDestruct (Collection []) = throwError (Default "empty collection")-consDestruct _ = throwError (Default "consDestruct : not collection")--snocDestruct :: Value -> IOThrowsError (ObjectRef, ObjectRef)-snocDestruct (Collection innerVals) =- case reverse innerVals of- Element eRef:rest -> do restRef <- liftIO (newIORef (Value (Collection (reverse rest))))- return (eRef, restRef)- SubCollection subRef:rest- -> do subVal <- cEval1 subRef- b <- isEmptyCollection subVal- if b- then snocDestruct (Collection (reverse rest))- else do (racRef, rdcRef) <- snocDestruct subVal- rdcVal <- cEval1 rdcRef- case rdcVal of- Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs))))- return (racRef, restRef)- _ -> undefined- _ -> undefined-snocDestruct _ = throwError (Default "snocDestruct : not collection")------- Builtin Functions----getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value)-getBuiltin name =- case name of- "open-input-file" -> Just builtinOpenInputFile- "open-output-file" -> Just builtinOpenInputFile- "close-input-file" -> Just builtinCloseInputFile- "close-output-file" -> Just builtinCloseOutputFile- "read" -> Just builtinRead- "write" -> Just builtinWrite- "print" -> Just builtinPrint- "read-char" -> Just builtinReadChar- "write-char" -> Just builtinWriteChar- "read-from-port" -> Just builtinReadFromPort- "write-to-port" -> Just builtinWriteToPort- "print-to-port" -> Just builtinPrintToPort- "read-char-from-port" -> Just builtinReadCharFromPort- "write-char-to-port" -> Just builtinWriteCharToPort- "=c" -> Just builtinEqualCharacter- "compare-character" -> Just builtinCompareCharacter- "int-to-float" -> Just builtinIntToFloat- "ceiling" -> Just builtinCeiling- "floor" -> Just builtinFloor- "truncate" -> Just builtinTruncate- "round" -> Just builtinRound- "=" -> Just builtinEqual- "compare-integer" -> Just builtinCompareInteger- "+" -> Just builtinPlus- "-" -> Just builtinMinus- "*" -> Just builtinMultiply- "dev" -> Just builtinDevide- "mod" -> Just builtinMod- "=f" -> Just builtinEqualFloat- "compare-float" -> Just builtinCompareFloat;- "+f" -> Just builtinPlusFloat- "-f" -> Just builtinMinusFloat- "*f" -> Just builtinMultiplyFloat- "/f" -> Just builtinDevideFloat--- "pi" -> Just builtinPi- "exp" -> Just builtinExp- "log" -> Just builtinLog- "sqrt" -> Just builtinSqrt- "**" -> Just builtinPower- "log-base" -> Just builtinLogBase- "sin" -> Just builtinSin- "cos" -> Just builtinCos- "tan" -> Just builtinTan- "asin" -> Just builtinAsin- "acos" -> Just builtinAcos- "atan" -> Just builtinAtan- "sinh" -> Just builtinSinh- "cosh" -> Just builtinCosh- "tanh" -> Just builtinTanh- "asinh" -> Just builtinAsinh- "acosh" -> Just builtinAcosh- "atanh" -> Just builtinAtanh- _ -> Nothing--builtinOpenInputFile :: [Value] -> IOThrowsError Value-builtinOpenInputFile [(World actions), val] = do- fileName <- charCollectionToString val- port <- liftM Port $ liftIO $ openFile fileName ReadMode- ret <- liftIO (makeTupleFromValueList [World ((OpenInputFile fileName):actions), (port fileName)])- return ret-builtinOpenInputFile _ = throwError (Default "invalid args to open-input-file")- -builtinOpenOutputFile :: [Value] -> IOThrowsError Value-builtinOpenOutputFile [(World actions), val] = do- fileName <- charCollectionToString val- port <- liftM Port $ liftIO $ openFile fileName WriteMode- ret <- liftIO (makeTupleFromValueList [World ((OpenOutputFile fileName):actions), (port fileName)])- return ret-builtinOpenOutputFile _ = throwError (Default "invalid args to open-output-file")- -builtinCloseInputFile :: [Value] -> IOThrowsError Value-builtinCloseInputFile [(World actions), (Port handle fileName)] = do- liftIO $ hClose handle- return (World ((CloseInputFile fileName):actions))-builtinCloseInputFile _ = throwError (Default "invalid args to close-input-file")- -builtinCloseOutputFile :: [Value] -> IOThrowsError Value-builtinCloseOutputFile [(World actions), (Port handle fileName)] = do- liftIO $ hClose handle- return (World ((CloseInputFile fileName):actions))-builtinCloseOutputFile _ = throwError (Default "invalid args to close-output-file")- -builtinRead :: [Value] -> IOThrowsError Value-builtinRead [(World actions)] = do- str <- liftIO (getExpressionHelper False 0)- val <- readValue str- ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])- return ret-builtinRead _ = throwError (Default "invalid args to read")- -builtinWrite :: [Value] -> IOThrowsError Value-builtinWrite [(World actions), val] = do- valStr <- showValue val- liftIO (flushStr valStr)- return (World ((Write val):actions))-builtinWrite _ = throwError (Default "invalid args to write")--builtinPrint :: [Value] -> IOThrowsError Value-builtinPrint [(World actions), val] = do- str <- charCollectionToString val- liftIO (flushStr str)- return (World ((Print str):actions))-builtinPrint _ = throwError (Default "invalid args to print")- -builtinReadChar :: [Value] -> IOThrowsError Value-builtinReadChar [(World actions)] = do- c <- liftIO getChar- ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])- return ret-builtinReadChar _ = throwError (Default "invalid args to read-char")--builtinWriteChar :: [Value] -> IOThrowsError Value-builtinWriteChar [(World actions), (Character c)] = do- liftIO (putChar c)- return (World ((Write (Character c)):actions))-builtinWriteChar _ = throwError (Default "invalid args to write-char")---builtinReadFromPort :: [Value] -> IOThrowsError Value-builtinReadFromPort [(World actions)] = do- str <- liftIO (getExpressionHelper False 0)- val <- readValue str- ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])- return ret-builtinReadFromPort _ = throwError (Default "invalid args to read-from-port")- -builtinWriteToPort :: [Value] -> IOThrowsError Value-builtinWriteToPort [(World actions), val] = do- valStr <- showValue val- liftIO (flushStr valStr)- return (World ((Write val):actions))-builtinWriteToPort _ = throwError (Default "invalid args to write-to-port")--builtinPrintToPort :: [Value] -> IOThrowsError Value-builtinPrintToPort [(World actions), val] = do- str <- charCollectionToString val- liftIO (flushStr str)- return (World ((Print str):actions))-builtinPrintToPort _ = throwError (Default "invalid args to print-to-port")- -builtinReadCharFromPort :: [Value] -> IOThrowsError Value-builtinReadCharFromPort [(World actions)] = do- c <- liftIO getChar- ret <- liftIO (makeTupleFromValueList [World ((Read (Character c)):actions), Character c])- return ret-builtinReadCharFromPort _ = throwError (Default "invalid args to read-char-from-port")--builtinWriteCharToPort :: [Value] -> IOThrowsError Value-builtinWriteCharToPort [(World actions), (Character c)] = do- liftIO (putChar c)- return (World ((Write (Character c)):actions))-builtinWriteCharToPort _ = throwError (Default "invalid args to write-char-to-port")---builtinEqualCharacter :: [Value] -> IOThrowsError Value-builtinEqualCharacter [(Character c1), (Character c2)] = if (c1 == c2)- then return (InductiveData "true" [])- else return (InductiveData "false" [])-builtinEqualCharacter _ = throwError (Default "invalid args to =c")--builtinCompareCharacter :: [Value] -> IOThrowsError Value-builtinCompareCharacter [(Character c1), (Character c2)] = if (c1 == c2)- then return (InductiveData "equal" [])- else if (c1 < c2)- then return (InductiveData "less" [])- else return (InductiveData "greater" [])-builtinCompareCharacter _ = throwError (Default "invalid args to compare-character")---builtinIntToFloat :: [Value] -> IOThrowsError Value-builtinIntToFloat [Integer n] = return (Double (fromInteger n))-builtinIntToFloat _ = throwError (Default "invalid args to int-to-float")--builtinCeiling :: [Value] -> IOThrowsError Value-builtinCeiling [Double d] = return (Integer (ceiling d))-builtinCeiling _ = throwError (Default "invalid args to ceiling")--builtinFloor :: [Value] -> IOThrowsError Value-builtinFloor [Double d] = return (Integer (floor d))-builtinFloor _ = throwError (Default "invalid args to floor")--builtinTruncate :: [Value] -> IOThrowsError Value-builtinTruncate [Double d] = return (Integer (truncate d))-builtinTruncate _ = throwError (Default "invalid args to truncate")--builtinRound :: [Value] -> IOThrowsError Value-builtinRound [Double d] = return (Integer (round d))-builtinRound _ = throwError (Default "invalid args to round")---builtinEqual :: [Value] -> IOThrowsError Value-builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2)- then return (InductiveData "true" [])- else return (InductiveData "false" [])-builtinEqual _ = throwError (Default "invalid args to =")--builtinCompareInteger :: [Value] -> IOThrowsError Value-builtinCompareInteger [(Integer n1), (Integer n2)] = if (n1 == n2)- then return (InductiveData "equal" [])- else if (n1 < n2)- then return (InductiveData "less" [])- else return (InductiveData "greater" [])-builtinCompareInteger _ = throwError (Default "invalid args to compare-integer")--builtinPlus :: [Value] -> IOThrowsError Value-builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2))-builtinPlus _ = throwError (Default "invalid args to +")--builtinMinus :: [Value] -> IOThrowsError Value-builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2))-builtinMinus _ = throwError (Default "invalid args to -")--builtinMultiply :: [Value] -> IOThrowsError Value-builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2))-builtinMultiply _ = throwError (Default "invalid args to *")--builtinDevide :: [Value] -> IOThrowsError Value-builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2))-builtinDevide _ = throwError (Default "invalid args to dev")--builtinMod :: [Value] -> IOThrowsError Value-builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2))-builtinMod _ = throwError (Default "invalid args to mod")---builtinEqualFloat :: [Value] -> IOThrowsError Value-builtinEqualFloat [(Double n1), (Double n2)] = if (n1 == n2)- then return (InductiveData "true" [])- else return (InductiveData "false" [])-builtinEqualFloat _ = throwError (Default "invalid args to =f")--builtinCompareFloat :: [Value] -> IOThrowsError Value-builtinCompareFloat [(Double n1), (Double n2)] = if (n1 == n2)- then return (InductiveData "equal" [])- else if (n1 < n2)- then return (InductiveData "less" [])- else return (InductiveData "greater" [])-builtinCompareFloat _ = throwError (Default "invalid args to compare-float")--builtinPlusFloat :: [Value] -> IOThrowsError Value-builtinPlusFloat [(Double n1), (Double n2)] = return (Double (n1 + n2))-builtinPlusFloat _ = throwError (Default "invalid args to +f")--builtinMinusFloat :: [Value] -> IOThrowsError Value-builtinMinusFloat [(Double n1), (Double n2)] = return (Double (n1 - n2))-builtinMinusFloat _ = throwError (Default "invalid args to -f")--builtinMultiplyFloat :: [Value] -> IOThrowsError Value-builtinMultiplyFloat [(Double n1), (Double n2)] = return (Double (n1 * n2))-builtinMultiplyFloat _ = throwError (Default "invalid args to *f")--builtinDevideFloat :: [Value] -> IOThrowsError Value-builtinDevideFloat [(Double n1), (Double n2)] = return (Double (n1 / n2))-builtinDevideFloat _ = throwError (Default "invalid args to /f")---builtinExp :: [Value] -> IOThrowsError Value-builtinExp [Double d] = return (Double (exp d))-builtinExp _ = throwError (Default "invalid args to exp")--builtinLog :: [Value] -> IOThrowsError Value-builtinLog [Double d] = return (Double (log d))-builtinLog _ = throwError (Default "invalid args to log")--builtinSqrt :: [Value] -> IOThrowsError Value-builtinSqrt [Double d] = return (Double (sqrt d))-builtinSqrt _ = throwError (Default "invalid args to sqrt")--builtinPower :: [Value] -> IOThrowsError Value-builtinPower [(Double n1), (Double n2)] = return (Double (n1 ** n2))-builtinPower _ = throwError (Default "invalid args to **")--builtinLogBase :: [Value] -> IOThrowsError Value-builtinLogBase [(Double n1), (Double n2)] = return (Double (logBase n1 n2))-builtinLogBase _ = throwError (Default "invalid args to log-base")--builtinSin :: [Value] -> IOThrowsError Value-builtinSin [Double d] = return (Double (sin d))-builtinSin _ = throwError (Default "invalid args to sin")--builtinCos :: [Value] -> IOThrowsError Value-builtinCos [Double d] = return (Double (cos d))-builtinCos _ = throwError (Default "invalid args to cos")--builtinTan :: [Value] -> IOThrowsError Value-builtinTan [Double d] = return (Double (tan d))-builtinTan _ = throwError (Default "invalid args to tan")--builtinAsin :: [Value] -> IOThrowsError Value-builtinAsin [Double d] = return (Double (asin d))-builtinAsin _ = throwError (Default "invalid args to asin")--builtinAcos :: [Value] -> IOThrowsError Value-builtinAcos [Double d] = return (Double (acos d))-builtinAcos _ = throwError (Default "invalid args to acos")--builtinAtan :: [Value] -> IOThrowsError Value-builtinAtan [Double d] = return (Double (atan d))-builtinAtan _ = throwError (Default "invalid args to atan")--builtinSinh :: [Value] -> IOThrowsError Value-builtinSinh [Double d] = return (Double (sinh d))-builtinSinh _ = throwError (Default "invalid args to sinh")--builtinCosh :: [Value] -> IOThrowsError Value-builtinCosh [Double d] = return (Double (cosh d))-builtinCosh _ = throwError (Default "invalid args to cosh")--builtinTanh :: [Value] -> IOThrowsError Value-builtinTanh [Double d] = return (Double (tanh d))-builtinTanh _ = throwError (Default "invalid args to tanh")--builtinAsinh :: [Value] -> IOThrowsError Value-builtinAsinh [Double d] = return (Double (asinh d))-builtinAsinh _ = throwError (Default "invalid args to asinh")--builtinAcosh :: [Value] -> IOThrowsError Value-builtinAcosh [Double d] = return (Double (acosh d))-builtinAcosh _ = throwError (Default "invalid args to acosh")--builtinAtanh :: [Value] -> IOThrowsError Value-builtinAtanh [Double d] = return (Double (atanh d))-builtinAtanh _ = throwError (Default "invalid args to atanh")------- For debug----debug :: String -> ObjectRef -> IOThrowsError ()-debug tag objRef = do- val <- cEval objRef- valStr <- showValue val- liftIO $ putStr $ tag ++ ": "- liftIO $ putStrLn valStr- -debug2 :: String -> ObjectRef -> IOThrowsError ()-debug2 tag objRef = do- objStr <- liftIO $ showObjectRef objRef- liftIO $ putStr $ tag ++ ": "- liftIO $ putStrLn objStr
egison.cabal view
@@ -1,73 +1,49 @@--- egison.cabal auto-generated by cabal init. For additional options,--- see--- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.--- The name of the package. Name: egison---- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version: 1.2.3---- A short (one-line) description of the package.+Version: 2.0.0 Synopsis: An Interpreter for the Programming Language Egison---- A longer description of the package. Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. With Egison, you can represent pattern matching for unfree data intuitively, especially for collection data, such as lists, multisets, sets, and so on. This package include sample Egison program codes "*-test.egi" in "etc/sample/" directory. This package also include Emacs Lisp file "egison-mode.el" in "etc/elisp/" directory.---- URL for the project homepage or repository. Homepage: http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/---- The license under which the package is released. License: MIT---- The file containing the license text. License-file: LICENSE---- The package author(s). Author: Satoshi Egi---- An email address to which users can send suggestions, bug reports,--- and patches. Maintainer: egisatoshi@gmail.com---- A copyright notice.--- Copyright: - Category: Compilers/Interpreters- Build-type: Simple+Cabal-version: >=1.8 -Data-Dir: etc/+Data-Dir: ./+Data-files: lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/graph.egi lib/poker-hands.egi sample/number-test.egi sample/collection-test.egi sample/graph-test.egi sample/io-test.egi sample/poker-hands-test.egi elisp/egison-mode.el -Data-files: lib/base.egi lib/number.egi lib/collection.egi lib/graph.egi lib/poker-hands.egi sample/number-test.egi sample/collection-test.egi sample/graph-test.egi sample/io-test.egi sample/poker-hands-test.egi elisp/egison-mode.el --- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files: ---- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.6+Library+ Build-Depends: base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths+ Hs-Source-Dirs: hs-src+ Exposed-Modules: Language.Egison.Core+ Language.Egison.Types+ Language.Egison.Variables+-- Language.Egison.Compiler+ Language.Egison.Numerical+ Language.Egison.Parser+ Language.Egison.Primitives Executable egison- -- .hs or .lhs file containing the Main module.- Main-is: Egison.hs- - -- Packages needed in order to build this package.- Build-depends: base >= 4.0 && < 5, mtl, parsec >= 3.0- - -- Modules not exported by this package.+ Main-is: egisoni.hs+ Build-depends: egison, base >= 4.0 && < 5, array, containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths Other-modules: Paths_egison+ Hs-Source-Dirs: hs-src/Interpreter - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.- -- Build-tools: +--Executable egisonc+-- Main-is: egisonc.hs+-- Build-depends: base >= 4.0 && < 5, haskell98, mtl, parsec >= 3.0+-- Other-modules: Paths_egison+-- Hs-Source-Dirs: hs-src/Compiler Source-Repository head type: git- location: https://github.com/egisatoshi/egison+ location: https://github.com/egisatoshi/egison2
+ elisp/egison-mode.el view
@@ -0,0 +1,165 @@+;;; egison-mode.el --- Egison editing mode++(defconst egison-font-lock-keywords-1+ (eval-when-compile+ (list+ "\\<define\\>"+ "\\<test\\>"+ "\\<execute\\>"+ + "\\<lambda\\>"+ "\\<macro\\>"+ "\\<do\\>"+ "\\<if\\>"+ "\\<let\\>"+ "\\<letrec\\>"+ "\\<type\\>"+ "\\<type-ref\\>"+ "\\<destructor\\>"+ "\\<loop\\>"+ "\\<match\\>"+ "\\<match-all\\>"++ "\\\."+ "\\\,"+ "\\\!"+ "\\\~"+ "\\\#"+ "|"+ "\\\&"+ "@"+ "\\<_\\>"+ ))+ "Subdued expressions to highlight in Egison modes.")++(defconst egison-font-lock-keywords-2+ (append egison-font-lock-keywords-1+ (eval-when-compile+ (list+ (cons "\\\$\\\w*" font-lock-variable-name-face)+ (cons ";.*$" font-lock-comment-face)+ )))+ "Gaudy expressions to highlight in Egison modes.")++(defvar egison-font-lock-keywords egison-font-lock-keywords-1+ "Default expressions to highlight in Egison modes.")+++(defun open-paren-p ()+ (let ((c (string-to-char (thing-at-point 'char))))+ (or (eq c 40) (eq c 60) (eq c 91) (eq c 123))))++(defun close-paren-p ()+ (let ((c (string-to-char (thing-at-point 'char))))+ (or (eq c 41) (eq c 62) (eq c 93) (eq c 125))))++(defun last-unclosed-paren ()+ (save-excursion+ (let ((pc 0))+ (while (<= pc 0)+ (if (bobp)+ (setq pc 2)+ (backward-char)+ (if (open-paren-p)+ (progn+ (setq pc (+ pc 1))+ (if (and (= pc 0) (= (current-column) 0))+ (setq pc 2)))+ (if (close-paren-p)+ (setq pc (- pc 1))))))+ (if (= pc 2)+ nil+ (point)))))++(defun indent-point ()+ (save-excursion+ (beginning-of-line)+ (let ((p (last-unclosed-paren)))+ (if p+ (progn+ (goto-char (last-unclosed-paren))+ (let ((cp (current-column)))+ (cond ((eq (string-to-char (thing-at-point 'char)) 40)+ (forward-char)+ (let* ((op (current-word))+ (ip (keyword-indent-point op)))+ (if ip+ (+ ip cp)+ (+ 2 (length op) cp))))+ ((eq (string-to-char (thing-at-point 'char)) 60)+ (forward-char)+ (let ((op (current-word)))+ (+ 2 (length op) cp)))+ (t (+ 1 cp)))))+ 0))))++(defun keyword-indent-point (name)+ (cond ((equal "define" name) 2)+ ((equal "lambda" name) 2)+ ((equal "macro" name) 2)+ ((equal "let" name) 2)+ ((equal "letrec" name) 2)+ ((equal "match" name) 2)+ ((equal "match-all" name) 2)+ ((equal "type" name) 2)+ ((equal "destructor" name) 2)+ ))++(defun egison-indent-line ()+ "indent current line as Egison code."+ (interactive)+ (indent-line-to (indent-point)))+++(defvar egison-mode-map+ (let ((smap (make-sparse-keymap)))+ (define-key smap "\C-j" 'newline-and-indent)+ smap)+ "Keymap for Egison mode.")+++(defvar egison-mode-syntax-table+ (let ((egison-mode-syntax-table (make-syntax-table)))+ (modify-syntax-entry 60 "(" egison-mode-syntax-table)+ (modify-syntax-entry 62 ")" egison-mode-syntax-table)+ egison-mode-syntax-table)+ "Syntax table for Egison mode")++(defun egison-mode-variables ()+ (set-syntax-table egison-mode-syntax-table)+ (set (make-local-variable 'font-lock-defaults)+ '((egison-font-lock-keywords+ egison-font-lock-keywords-1 egison-font-lock-keywords-2)+ nil t (("+-*/=?%:_" . "w") ("<" . "(") (">" . ")"))+ ))+ (set (make-local-variable 'indent-line-function)+ 'egison-indent-line)+ )+++(defun egison-mode ()+ "Major mode for editing Egison code.++Commands:+\\{egison-mode-map}+Entry to this mode calls the value of `egison-mode-hook'+if that value is non-nil."+ (interactive)+ (kill-all-local-variables)+ (use-local-map egison-mode-map)+ (setq major-mode 'egison-mode)+ (setq mode-name "Egison")+ (egison-mode-variables)+ (run-mode-hooks 'egison-mode-hook))+++(defgroup egison nil+ "Editing Egison code."+ :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)+ :group 'lisp)++(defcustom egison-mode-hook nil+ "Normal hook run when entering `egison-mode'.+See `run-hooks'."+ :type 'hook+ :group 'egison)
− etc/elisp/egison-mode.el
@@ -1,162 +0,0 @@-;;; egison-mode.el --- Egison editing mode--(defconst egison-font-lock-keywords-1- (eval-when-compile- (list- "\\<define\\>"- "\\<test\\>"- "\\<execute\\>"- - "\\<lambda\\>"- "\\<macro\\>"- "\\<do\\>"- "\\<let\\>"- "\\<type\\>"- "\\<type-ref\\>"- "\\<destructor\\>"- "\\<loop\\>"- "\\<match\\>"- "\\<match-all\\>"-- "\\\."- "\\\,"- "\\\!"- "\\\~"- "\\\#"- "|"- "\\\&"- "@"- "\\<_\\>"- ))- "Subdued expressions to highlight in Egison modes.")--(defconst egison-font-lock-keywords-2- (append egison-font-lock-keywords-1- (eval-when-compile- (list- (cons "\\\$\\\w*" font-lock-variable-name-face)- (cons ";.*$" font-lock-comment-face)- )))- "Gaudy expressions to highlight in Egison modes.")--(defvar egison-font-lock-keywords egison-font-lock-keywords-1- "Default expressions to highlight in Egison modes.")---(defun open-paren-p ()- (let ((c (string-to-char (thing-at-point 'char))))- (or (eq c 40) (eq c 60) (eq c 91) (eq c 123))))--(defun close-paren-p ()- (let ((c (string-to-char (thing-at-point 'char))))- (or (eq c 41) (eq c 62) (eq c 93) (eq c 125))))--(defun last-unclosed-paren ()- (save-excursion- (let ((pc 0))- (while (<= pc 0)- (if (bobp)- (setq pc 2)- (backward-char)- (if (open-paren-p)- (progn- (setq pc (+ pc 1))- (if (and (= pc 0) (= (current-column) 0))- (setq pc 2)))- (if (close-paren-p)- (setq pc (- pc 1))))))- (if (= pc 2)- nil- (point)))))--(defun indent-point ()- (save-excursion- (beginning-of-line)- (let ((p (last-unclosed-paren)))- (if p- (progn- (goto-char (last-unclosed-paren))- (let ((cp (current-column)))- (cond ((eq (string-to-char (thing-at-point 'char)) 40)- (forward-char)- (let* ((op (current-word))- (ip (keyword-indent-point op)))- (if ip- (+ ip cp)- (+ 2 (length op) cp))))- ((eq (string-to-char (thing-at-point 'char)) 60)- (forward-char)- (let ((op (current-word)))- (+ 2 (length op) cp)))- (t (+ 1 cp)))))- 0))))--(defun keyword-indent-point (name)- (cond ((equal "define" name) 2)- ((equal "lambda" name) 2)- ((equal "macro" name) 2)- ((equal "let" name) 2)- ((equal "match" name) 2)- ((equal "match-all" name) 2)- ((equal "type" name) 2)- ((equal "destructor" name) 2)- ))--(defun egison-indent-line ()- "indent current line as Egison code."- (interactive)- (indent-line-to (indent-point)))---(defvar egison-mode-map- (let ((smap (make-sparse-keymap)))- (define-key smap "\C-j" 'newline-and-indent)- smap)- "Keymap for Egison mode.")---(defvar egison-mode-syntax-table- (let ((egison-mode-syntax-table (make-syntax-table)))- (modify-syntax-entry 60 "(" egison-mode-syntax-table)- (modify-syntax-entry 62 ")" egison-mode-syntax-table)- egison-mode-syntax-table)- "Syntax table for Egison mode")--(defun egison-mode-variables ()- (set-syntax-table egison-mode-syntax-table)- (set (make-local-variable 'font-lock-defaults)- '((egison-font-lock-keywords- egison-font-lock-keywords-1 egison-font-lock-keywords-2)- nil t (("+-*/=?%:_" . "w") ("<" . "(") (">" . ")"))- ))- (set (make-local-variable 'indent-line-function)- 'egison-indent-line)- )---(defun egison-mode ()- "Major mode for editing Egison code.--Commands:-\\{egison-mode-map}-Entry to this mode calls the value of `egison-mode-hook'-if that value is non-nil."- (interactive)- (kill-all-local-variables)- (use-local-map egison-mode-map)- (setq major-mode 'egison-mode)- (setq mode-name "Egison")- (egison-mode-variables)- (run-mode-hooks 'egison-mode-hook))---(defgroup egison nil- "Editing Egison code."- :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)- :group 'lisp)--(defcustom egison-mode-hook nil- "Normal hook run when entering `egison-mode'.-See `run-hooks'."- :type 'hook- :group 'egison)
− etc/lib/base.egi
@@ -1,65 +0,0 @@-;;-;; Base.egi-;;---(define $Something (type {[$var-match (lambda [$tgt] {tgt})]}))--(define $Bool- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[true []- {[<true> {[]}]- [_ {}]}]- [false []- {[<false> {[]}]- [_ {}]}]})]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Bool Bool]- {[[<true> <true>] <true>]- [[<false> <false>] <true>]- [[_ _] <false>]}))]}))--(define $or- (lambda [$b1 $b2]- (match b1 Bool- {[<true> <true>]- [<false> b2]})))--(define $and- (lambda [$b1 $b2]- (match b1 Bool- {[<true> b2]- [<false> <false>]})))--(define $not- (lambda [$b]- (match b Bool- {[<true> <false>]- [<false> <true>]})))--(define $Order- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[less []- {[<less> {[]}]- [_ {}]}]- [equal []- {[<equal> {[]}]- [_ {}]}]- [greater []- {[<greater> {[]}]- [_ {}]}]})]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Order Order]- {[[<less> <less>] <true>]- [[<equal> <equal>] <true>]- [[<greater> <greater>] <true>]- [[_ _] <false>]}))]}))-
− etc/lib/collection.egi
@@ -1,193 +0,0 @@-;;-;; Collection.egi-;;--(define $List- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[nil []- {[{} {[]}]- [_ {}]}]- [cons [a (List a)]- {[{$x .$xs} {[x xs]}]- [_ {}]}]- [snoc [a (List a)]- {[{.$xs $x} {[x xs]}]- [_ {}]}]- [join [(List a) (List a)]- {[$tgt (let {[$loop-fn- (lambda [$ts]- (match ts (List a)- {[<nil> {[{} {}]}]- [<cons $x $xs>- {[{} ts]- @(map (lambda [$as $bs] [{x @as} bs])- (loop-fn xs))}]}))]}- (loop-fn tgt))]}]- [nioj [(List a) (List a)]- {[$tgt (let {[$loop-fn- (lambda [$ts]- (match ts (List a)- {[<nil> {[{} {}]}]- [<snoc $x $xs>- {[{} ts]- @(map (lambda [$as $bs] [{@as x} bs])- (loop-fn xs))}]}))]}- (loop-fn tgt))]}]})]- [$equal? (lambda [$val $tgt]- (match [val tgt] [(List a) (List a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs> <cons ,x ,xs>] <true>]- [[_ _] <false>]}))]})))--(define $map- (lambda [$fn $ls]- (match ls (List Something)- {[<nil> {}]- [<cons $x $xs> {(fn x) @(map fn xs)}]})))--(define $remove- (lambda [$a]- (lambda [$xs $x]- (match xs (List a)- {[<nil> {}]- [<cons ,x $rs> rs]- [<cons $y $rs> {y @((remove a) rs x)}]}))))--(define $remove-all- (lambda [$a]- (lambda [$xs $x]- (match xs (List a)- {[<nil> {}]- [<cons ,x $rs> ((remove-all a) rs x)]- [<cons $y $rs> {y @((remove-all a) rs x)}]}))))--(define $remove-collection- (lambda [$a]- (lambda [$xs $ys]- (match ys (List a)- {[<nil> xs]- [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))--(define $add- (lambda [$a]- (lambda [$xs $x]- (match ((member? a) x xs) Bool- {[<true> xs]- [<false> {@xs x}]}))))--(define $union- (lambda [$a]- (lambda [$xs $ys]- (match ys (List a)- {[<nil> xs]- [<cons $y $rs> ((union a) ((add a) xs y) rs)]}))))--(define $subcollections- (lambda [$xs]- (match xs (List Something)- {[<nil> {{}}]- [<cons $x $rs>- (let {[$subs (subcollections rs)]}- {@subs @(map (lambda [$sub] {x @sub})- subs)})]})))--(define $size- (lambda [$xs]- (match xs (List Something)- {[<nil> 0]- [<cons _ $rs> (+ 1 (size rs))]})))--(define $car- (lambda [$xs]- (match xs (List Something)- {[<cons $x _> x]})))--(define $reverse- (lambda [$xs]- (match xs (List Something)- {[<nil> {}]- [<cons $x $rs>- {@(reverse rs) x}]})))--(define $member?- (lambda [$a]- (lambda [$x $ys]- (match ys (List a)- {[<nil> <false>]- [<cons ,x $ys> <true>]- [<cons $y $ys> ((member? a) x ys)]}))))--(define $unique- (lambda [$a]- (lambda [$xs]- (let {[$loop-fn (lambda [$xs $ys]- (match xs (List a)- {[<nil> ys]- [<cons $x $rs>- (match ((member? a) x ys) Bool- {[<true> (loop-fn rs ys)]- [<false> (loop-fn rs {@ys x})]- [_ {}]})]}))]}- (loop-fn xs {})))))--(define $subcollection?- (lambda [$a]- (lambda [$xs $ys]- (match xs (List a)- {[<nil> <true>]- [<cons $x $rest>- (match ((member? a) x ys) Bool- {[<false> <false>]- [<true> ((subcollection? a) rest ys)]})]}))))--(define $concat- (lambda [$xs]- (match xs (List Something)- {[<nil> {}]- [<cons $x $rs> {@x @(concat rs)}]})))--(define $Multiset- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[nil []- {[{} {[]}]- [_ {}]}]- [cons [a (Multiset a)]- {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])- ((unique a) tgt))]}]- [join [(Multiset a) (Multiset a)]- {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])- (subcollections tgt))]}]})]- [$equal? (lambda [$val $tgt]- (match [val tgt] [(Multiset a) (Multiset a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs> <cons ,x ,xs>] <true>]- [[_ _] <false>]}))]})))--(define $Set- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[nil []- {[{} {[]}]- [_ {}]}]- [cons [a (Set a)]- {[$tgt (let {[$tgt2 ((unique a) tgt)]}- {@(match-all tgt2 (Multiset a) [<cons $x $xs> [x xs]])- @(match-all tgt2 (Multiset a) [<cons $x $xs> [x {@xs x}]])})]}]- [join [(Set a) (Set a)]- {[$tgt (let {[$tgt2 ((unique a) tgt)]}- (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}])- (subcollections xs)))- (match-all tgt2 (Multiset a) [<join $xs $ys> [xs ys]]))))]}]})]- [$equal? (lambda [$val $tgt]- (and ((subcollection? a) val tgt) ((subcollection? a) tgt val)))]})))
− etc/lib/graph.egi
@@ -1,43 +0,0 @@-(define $Node Integer)--(define $NodeInfo- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[node [Node (Multiset Node) (Multiset Node)]- {[<node $n $in $out> {[n in out]}]}]})]- [$equal? (lambda [$val $tgt]- (match [val tgt] [NodeInfo NodeInfo]- {[[<node $n $in $out> <node ,n ,in ,out>] <true>]- [[_ _] <false>]}))]}))--(define $Graph (Multiset NodeInfo))---(define $hamilton-cycle- (lambda [$g]- (let {[$n (size g)]}- (match-all g Graph- [<cons <node $a_1 <cons $a_2 _> _>- (loop $l $i (between 3 n)- <cons <node ,a_(- i 1) <cons $a_i _> _>- l>- <cons <node ,a_n <cons ,a_1 _> _>- _>)>- [@(loop $l $i (between 1 n) {a_i @l} {})]- ]))))--(define $hamilton-path- (lambda [$g]- (let {[$n (size g)]}- (match-all g Graph- [<cons <node $a_1 <cons $a_2 _> _>- (loop $l $i (between 3 n)- <cons <node ,a_(- i 1) <cons $a_i _> _>- l>- <cons <node ,a_n _ _>- <nil>>)>- [@(loop $l $i (between 1 n) {a_i @l} {})]- ]))))-
− etc/lib/number.egi
@@ -1,62 +0,0 @@-(define $Integer- (type- {[$var-match (lambda [$tgt] {tgt})]- [$equal? (lambda [$val $tgt] (= val tgt))]}))--(define $Double- (type- {[$var-match (lambda [$tgt] {tgt})]- [$equal? (lambda [$val $tgt] (=f val tgt))]}))--(define $Nat- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[o []- {[0 {[]}]- [_ {}]}]- [s [Nat]- {[$tgt (match (compare-integer tgt 0) Order- {[<greater> {(- tgt 1)}]- [_ {}]})]}]})]- [$equal? (lambda [$val $tgt] (= val tgt))]}))--(define $between- (lambda [$m $n]- (match (compare-integer m n) Order- {[<less> {m @(between (+ m 1) n)}]- [<equal> {n}]- [<greater> {}]- })))--(define $min- (lambda [$ns]- (match ns (List Integer)- {[<cons $n <nil>> n]- [<cons $n $rs>- (let {[$r (min rs)]}- (match (compare-integer n r) Order- {[<less> n]- [_ r]}))]})))--(define $max- (lambda [$ns]- (match ns (List Integer)- {[<cons $n <nil>> n]- [<cons $n $rs>- (let {[$r (max rs)]}- (match (compare-integer n r) Order- {[<greater> n]- [_ r]}))]})))--(define $gcd- (lambda [$ns]- (match ns (Set Integer)- {[<cons $n <nil>> n]- [<cons (& ,(min ns) $m)- $rs>- (gcd {m @((remove-all Integer)- (map (lambda [$r] (mod r m))- rs)- 0)})]})))
− etc/lib/poker-hands.egi
@@ -1,110 +0,0 @@-(define $Suit- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[spade []- {[<spade> {[]}]- [_ {}]}]- [heart []- {[<heart> {[]}]- [_ {}]}]- [club []- {[<club> {[]}]- [_ {}]}]- [diamond []- {[<diamond> {[]}]- [_ {}]}]})]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Suit Suit]- {[[<spade> <spade>] <true>]- [[<heart> <heart>] <true>]- [[<club> <club>] <true>]- [[<diamond> <diamond>] <true>]- [[_ _] <false>]}))]}))--(define $Mod- (lambda [$m]- (type- {[$var-match (lambda [$tgt] {(mod tgt m)})]- [$equal? (lambda [$val $tgt] (= (mod val m) (mod tgt m)))]})))--(define $Card- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[card [Suit (Mod 13)]- {[<card $s $n> {[s n]}]}]})]- [$equal? (lambda [$val $tgt]- (match [val tgt] [Card Card]- {[[<card $s $n> <card ,s ,n>] <true>]- [[_ _] <false>]}))]}))--(define $poker-hands- (lambda [$Cs]- (match Cs (Multiset Card)- {[<cons <card $S $n>- <cons <card ,S ,(- n 1)>- <cons <card ,S ,(- n 2)>- <cons <card ,S ,(- n 3)>- <cons <card ,S ,(- n 4)>- !<nil>>>>>>- <straight-flush>]- [<cons <card _ $n>- <cons <card _ ,n>- !<cons <card _ ,n>- !<cons <card _ ,n>- !<cons _- !<nil>>>>>>- <four-of-kind>]- [<cons <card _ $m>- <cons <card _ ,m>- <cons <card _ ,m>- <cons <card _ $n>- !<cons <card _ ,n>- !<nil>>>>>>- <full-house>]- [<cons <card $S _>- !<cons <card ,S _>- !<cons <card ,S _>- !<cons <card ,S _>- !<cons <card ,S _>- !<nil>>>>>>- <flush>]- [<cons <card _ $n>- <cons <card _ ,(- n 1)>- <cons <card _ ,(- n 2)>- <cons <card _ ,(- n 3)>- <cons <card _ ,(- n 4)>- !<nil>>>>>>- <straight>]- [<cons <card _ $n>- <cons <card _ ,n>- <cons <card _ ,n>- <cons _- <cons _- !<nil>>>>>>- <three-of-kind>]- [<cons <card _ $m>- <cons <card _ ,m>- !<cons <card _ $n>- <cons <card _ ,n>- !<cons _- !<nil>>>>>>- <two-pair>]- [<cons <card _ $n>- <cons <card _ ,n>- <cons _- <cons _- <cons _- !<nil>>>>>>- <one-pair>]- [<cons _- <cons _- <cons _- <cons _- <cons _- !<nil>>>>>>- <nothing>]})))
− etc/sample/collection-test.egi
@@ -1,200 +0,0 @@-(test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer))- [<cons <cons $x _>- <cons <cons $y _>- <cons <cons $z _>- <nil>>>>- [x y z]]))--(test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Integer))- [<cons <cons $n _>- <cons <cons ,n _>- <cons <cons ,n _>- <nil>>>>- n]))--(test (match-all {1 2 3 4 5} (Multiset Integer)- [<cons $m <cons $n _>> [m n]]))--(test (let {[$pat <cons ,1 <nil>>]}- (match {1} (Multiset Integer)- {[pat <ok>]- [_ <not-ok>]})))--(test (match {1} (Multiset Integer)- {[(| <nil> <cons ,1 <nil>>) <ok>]- [_ <not-ok>]}))--(test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))--(test (match-all {1 2 3} (List Integer)- [<join $hs $ts> [hs ts]]))--(test (match-all {1 2 3} (List Integer)- [<nioj $hs $ts> [hs ts]]))--(test (match-all {1 2 3} (Multiset Integer)- [<join $hs $ts> [hs ts]]))--(test (match-all {1 2 3} (Set Integer)- [<join $hs $ts> [hs ts]]))--(test (match-all {1 2 3} (List Integer)- [<join $hs <cons $x $ts>> [hs x ts]]))--(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))--(test (subcollections {<x> <y> <z>}))--(test (poker-hands {<card <club> 4>- <card <club> 2>- <card <club> 5>- <card <club> 1>- <card <club> 3>}))--(test (poker-hands {<card <diamond> 1>- <card <club> 2>- <card <club> 1>- <card <heart> 1>- <card <diamond> 2>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 2>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 10>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))--(test (match {2 7 7 2 7} (Multiset Integer)- {[<cons $m- <cons ,m- <cons ,m- <cons $n- !<cons ,n- !<nil>>>>>>- <ok>]- [_ <ko>]}))--(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer)- [<cons $x- <cons $y- <cons $z- <nil>>>>- [x y z]]))--(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer)- [<cons $x- <cons $y- <cons $z- !<nil>>>>- [x y z]]))--(test (match {5 2 1 3 4} (Multiset Integer)- {[<cons $n- <cons ,(- n 1)- <cons ,(- n 2)- <cons ,(- n 3)- <cons ,(- n 4)- <nil>>>>>>- <ok>]- [_ <ko>]}))--(test (let {[$f (lambda [$x] (+ (g x) 10))]- [$g (lambda [$x] (+ x 1))]}- (f 0)))---(define $Stick- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[nil []- {[$tgt (match-all tgt (List a) [<nil> []])]}]- [cons [a (List a)]- {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])- @(match-all (reverse tgt) (List a) [<cons $x $xs> [x xs]])}]}]- [join [(List a) (List a)]- {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])- @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]}]})]- [$equal? (lambda [$val $tgt]- (or ((type-ref (List a) equal?) val tgt)- ((type-ref (List a) equal?) val (reverse tgt))))]})))--(test (match-all {1 2 3} (Stick Integer) [<cons $x $xs> [x xs]]))-(test (match-all {1 2 3} (Stick Integer) [<join $xs $ys> [xs ys]]))-(test (match-all {1 2 3 4} (Stick Integer) [<join $xs <cons $w $ys>> [xs w ys]]))-(test (match-all {1 2 3} (Stick Integer) [,{3 2 1} <ok>]))--(test (match-all {1 2 3 4 5} (List Integer)- [<join _ <cons $m <join _ <cons $n _>>>> [m n]]))--(test (match-all {1 2 3 4} (List Integer)- [<join _ <join $ns _>> ns]))--(define $combination- (lambda [$xs $k]- (match k Nat- {[<o> {{}}]- [<s $k1>- (concat (match-all xs (List Something)- [<join _ <cons $x $rs>>- (map (lambda [$ys]- {x @ys})- (combination rs k1))]))]})))--(test (combination {1 2 3 4 5} 3))--<join _ <cons $n_1 ... <join _ <cons $n_k _>> ... >>--(... [$n Integer (squence 1 k (lambda [$i] (+ i 1)))]- <join _ <cons $n_i ...>> _)--(define $loop-pat- (lambda [$k $i]- (match i Integer- {[,k <join _ <cons $n_k _>>]- [_ <join _ <cons $n_i (loop-pat k (+ i 1))>>]})))--(define $loop-pat- (lambda [$k]- (| <nil> <cons ,k (loop-pat (- k 1))>)))--(define $isStraight?- (lambda [$Ns]- (match Ns (Multiset Integer)- {[<cons $n- (loop-pat (- n 1))>- <ok>]- [_ <ko>]})))--(define $isStraight?- (lambda [$Ns]- (match Ns (Multiset Integer)- {[<cons (as $n (max Ns))- (loop-pat (- n 1))>- <ok>]- [_ <ko>]})))--(test (isStraight? {1 2}))--(define $CompactList- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (destructor- {[nil []- {[$tgt (match-all tgt (List a) [<nil> []])]}]- [cons [a (List a)]- {[$tgt - [join [(List a) (List a)]- {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])- @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]}]})]- [$equal? (lambda [$val $tgt]- )]})))
− etc/sample/graph-test.egi
@@ -1,34 +0,0 @@-(define $g {<node 1 {2 3 4 5} {2 3 4 5}>- <node 2 {1 3} {1 3}>- <node 3 {1 2 4} {1 2 4}>- <node 4 {1 3 5} {1 3 5}>- <node 5 {1 5} {1 5}>})--(test (match-all g Graph- [<cons <node $n1 <cons $n2 _> _>- <cons <node ,n2 <cons $n3 _> _>- <cons <node ,n3 <cons ,n1 _> _>- _>>>- [n1 n2 n3]]))--(test (match-all g Graph- [<cons <node $n1 <cons $n2 _> _>- <cons <node ,n2 <cons $n3 _> _>- <cons <node ,n3 <cons $n4 _> _>- <cons <node ,n4 <cons $n5 _> _>- <cons <node ,n5 <cons ,n1 _> _>- _>>>>>- [n1 n2 n3 n4 n5]]))--(test (match-all g Graph- [<cons <node $n1 <cons $n2 _> _>- <cons <node ,n2 <cons $n3 _> _>- <cons <node ,n3 <cons $n4 _> _>- <cons <node ,n4 <cons $n5 _> _>- <cons <node ,n5 _ _>- <nil>>>>>>- [n1 n2 n3 n4 n5]]))--(test (hamilton-cycle g))--(test (hamilton-path g))
− etc/sample/io-test.egi
@@ -1,37 +0,0 @@-(define $main- (lambda [$:]- (do {[$: (print : "input char : ")]- [[$: $c] (read-char :)]- [$: (print : "output : ")]- [$: (write-char : c)]- [$: (write-char : '\n')]- [$: (print : "input number :")]- [[$: $e] (read :)]- [$: (print : "output : ")]- [$: (write : e)]- [$: (write-char : '\n')]}- :)))--(execute)---(define $main- (lambda [$:]- (do {[$: (print : "Return world? (y/n) : ")]- [[$: $c] (read-char :)]}- (match c Character- {['y' :]- ['n' 0]}))))--(execute)---(define $main- (lambda [$:]- (do {[$: (print : "Return world? (1/0) : ")]- [[$: $n] (read :)]}- (match n Integer- {[,1 :]- [,0 0]}))))--(execute)
− etc/sample/number-test.egi
@@ -1,38 +0,0 @@-(define $fib- (lambda [$n]- (match n Nat- {[<o> 1]- [<s <o>> 1]- [<s <s $n1>> (+ (fib (+ n1 1)) (fib n1))]})))--(test (fib 10))--(define $fact- (lambda [$n]- (match n Nat- {[<o> 1]- [<s $n1> (* n (fact n1))]})))--(test (fact 10))--(define $min- (lambda [$ns]- (match ns (List Integer)- {[<cons $n <nil>> n]- [<cons $n $rs>- (let {[$r (min rs)]}- (match (compare-integer n r) Order- {[<less> n]- [_ r]}))]})))--(define $gcd- (lambda [$ns]- (let {[$ns2 ((remove-all Integer) ns 0)]}- (match ns2 (Set Integer)- {[<cons $n <nil>> n]- [<cons ,(min ns2)- $rs>- (gcd {(min ns2) @(map (lambda [$r] (mod r (min ns2)))- rs)})]}))))--(test (gcd {10 20 40 35}))
− etc/sample/poker-hands-test.egi
@@ -1,23 +0,0 @@-(test (poker-hands {<card <club> 4>- <card <club> 2>- <card <club> 5>- <card <club> 1>- <card <club> 3>}))--(test (poker-hands {<card <diamond> 1>- <card <club> 2>- <card <club> 1>- <card <heart> 1>- <card <diamond> 2>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 2>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 10>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))
+ hs-src/Interpreter/egisoni.hs view
@@ -0,0 +1,88 @@+module Main where+import Paths_egison+import Language.Egison.Core -- Egison Interpreter+import Language.Egison.Types -- Egison data types+import Language.Egison.Variables -- Egison variable operations+--import Control.Monad (when)+import Control.Monad.Error+import System.IO+import System.Environment+import System.Console.Haskeline++main :: IO ()+main = do args <- getArgs+ if null args then do showBanner+ runRepl+ else runOne $ args++-- REPL Section+flushStr :: String -> IO ()+flushStr str = putStr str >> hFlush stdout++-- |Execute a single egison file from the command line+runOne :: [String] -> IO ()+runOne args = do+ env <- primitiveBindings+ -- Load standard library+ _ <- loadLibraries env+ result <- runIOThrows $ liftM show $ evalTopExpr env $ Load (args !! 0)+ case result of+ Just errMsg -> putStrLn errMsg+ _ -> do + -- Call into (main) if it exists...+ alreadyDefined <- liftIO $ isBound env ("main", [])+ when alreadyDefined (do+ mainResult <- runIOThrows $ liftM show $ evalMain env $ args+ case mainResult of+ Just errMsg -> putStrLn errMsg+ _ -> return ())++-- |Load standard libraries into the given environment+loadLibraries :: Env -> IO ()+loadLibraries env = do+ -- Load standard library+ _ <- evalString env $ "(load \"lib/core/base.egi\")"+ _ <- evalString env $ "(load \"lib/core/number.egi\")"+ _ <- evalString env $ "(load \"lib/core/collection.egi\")"+ return ()++-- |Start the REPL (interactive interpreter)+runRepl :: IO ()+runRepl = do+ env <- primitiveBindings+ _ <- loadLibraries env+ runInputT defaultSettings (loop env "> " "")+ where+ loop :: Env -> String -> String -> InputT IO ()+ loop env prompt input0 = do+ minput <- getInputLine prompt+ case minput of+ Nothing -> liftIO showByebyeMessage+ Just "" -> if input0 == ""+ then loop env "> " ""+ else loop env " " (input0 ++ "\n")+ Just input ->+ let newInput = input0 ++ input in+ if (countParens newInput)+ then do result <- liftIO (evalString env newInput)+ if (length result) > 0+ then do outputStrLn result+ loop env "> " ""+ else loop env "> " ""+ else loop env " " newInput++countParens :: String -> Bool+countParens str = let countOpen = length $ filter ((==) '(') str in+ let countClose = length $ filter ((==) ')') str in+ (countOpen > 0) && (countOpen <= countClose)+-- End REPL Section++-- Begin Util section, of generic functions++{- Remove leading/trailing white space from a string; based on corresponding Python function+ Code taken from: http://gimbo.org.uk/blog/2007/04/20/splitting-a-string-in-haskell/ -}+strip :: String -> String+strip s = dropWhile ws $ reverse $ dropWhile ws $ reverse s+ where ws = (`elem` [' ', '\n', '\t', '\r'])++-- End Util
+ hs-src/Language/Egison/Core.hs view
@@ -0,0 +1,816 @@+module Language.Egison.Core where+import Language.Egison.Numerical+import Language.Egison.Parser+import Language.Egison.Primitives+import Language.Egison.Types+import Language.Egison.Variables+import Control.Monad.Error+import Data.Array+import qualified Data.Map+import qualified System.Exit+import System.Directory (doesFileExist, removeFile)+import System.IO+import Data.IORef+import Paths_egison++-- |egison version number+version :: String+version = "2.0.0"++-- |A utility function to display the egison console banner+showBanner :: IO ()+showBanner = do+ putStrLn $ "Egison Version " ++ version ++ " (c) 2011-2012 Satoshi Egi"+ putStrLn $ "http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/"+ putStrLn $ "Welcome to Egison Interpreter!"++-- |A utility function to display the egison console byebye message+showByebyeMessage :: IO ()+showByebyeMessage = do+ putStrLn $ "Leaving Egison."+ putStrLn $ "Byebye. See you again! (^^)/"++--libraries :: [String]+--libraries = ["lib/core/base.egi", "lib/core/number.egi", "lib/core/collection.egi"]+ +-- |A utility function to escape backslashes in the given string+escapeBackslashes :: String -> String+escapeBackslashes s = foldr step [] s+ where step x xs | x == '\\' = '\\' : '\\' : xs+ | otherwise = x : xs +++evalString :: Env -> String -> IO String+evalString env str = runIOThrowsREPL $ (liftThrows $ readTopExpr str) >>= evalTopExpr env++evalMain :: Env -> [String] -> IOThrowsError EgisonVal+evalMain env args = do+ let mainExpr = VarExpr "main" []+ main <- cEval1 $ Closure env mainExpr+ mainRef <- liftIO $ newIORef main+ let argvExpr = CollectionExpr $ map (ElementExpr . StringExpr) args+ argv <- cEval1 $ Closure env argvExpr+ argvRef <- liftIO $ newIORef argv+ worldRef <- liftIO $ newIORef $ Value $ World []+ argsRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ [IElement worldRef, IElement argvRef]+ ret <- cApply1 mainRef argsRef+ cEval ret++-- |Evaluate egison top expression that has already been loaded into haskell+evalTopExpr :: Env -> TopExpr -> IOThrowsError String+evalTopExpr env (Test expr) = liftM show $ eval env expr+evalTopExpr env (Define name expr) = do clr <- liftIO $ makeClosure env expr+ defineVar env (name, []) clr+ return name+evalTopExpr env (Execute args) = do evalMain env args+ return ""+evalTopExpr env (LoadFile filename) = do+ result <- liftIO $ doesFileExist filename+ if result+ then do (liftIO $ readFile filename) >>= load env+ return $ filename ++ " loaded."+ else throwError $ Default $ "File does not exist: " ++ filename+evalTopExpr env (Load libname) = do+ filename <- liftIO (getDataFileName libname)+ result <- liftIO $ doesFileExist filename+ if result+ then do (liftIO $ readFile filename) >>= load env+ return $ filename ++ " loaded."+ else throwError $ Default $ "Library does not exist: " ++ libname++ +load :: Env -> String -> IOThrowsError ()+load env str = do+ exprs <- liftThrows $ readTopExprList str+ mapM (evalTopExpr env) exprs+ return ()++-- |Evaluate egison expression that has already been loaded into haskell+eval :: Env -> EgisonExpr -> IOThrowsError EgisonVal+eval env expr = do+ obj <- cEval1 (Closure env expr)+ case obj of+ Value val -> return val+ Intermidiate iVal -> iEval iVal+ _ -> throwError $ Default $ "eval: cannot reach here!: " ++ show obj++iEval :: IntermidiateVal -> IOThrowsError EgisonVal+iEval (IInductiveData cons argRefs) = do+ args <- mapM cRefEval argRefs+ return $ InductiveData cons args+iEval (ICollection innerValRefs) = do+ innerVals <- mapM innerValRefEval innerValRefs+ return $ Collection innerVals+iEval (ITuple innerValRefs) = do+ innerVals <- mapM innerValRefEval innerValRefs+ return $ Tuple innerVals++innerValRefEval :: InnerValRef -> IOThrowsError InnerVal+innerValRefEval (IElement objRef) = liftM Element $ cRefEval objRef+innerValRefEval (ISubCollection objRef) = liftM SubCollection $ cRefEval objRef++cRefEval :: ObjectRef -> IOThrowsError EgisonVal+cRefEval objRef = do+ obj <- liftIO $ readIORef objRef+ val <- cEval obj+ liftIO $ writeIORef objRef $ Value val+ return val++cRefEval1 :: ObjectRef -> IOThrowsError Object+cRefEval1 objRef = do+ obj <- liftIO $ readIORef objRef+ obj2 <- cEval1 obj+ liftIO $ writeIORef objRef obj2+ return obj2++cEval :: Object -> IOThrowsError EgisonVal+cEval (Closure env expr) = eval env expr+cEval (Value val) = return val+cEval (Intermidiate iVal) = iEval iVal++cEval1 :: Object -> IOThrowsError Object+cEval1 (Closure _ (BoolExpr contents)) = return $ Value (Bool contents)+cEval1 (Closure _ (CharExpr contents)) = return $ Value (Char contents)+cEval1 (Closure _ (StringExpr contents)) = return $ Value (String contents)+cEval1 (Closure _ (NumberExpr contents)) = return $ Value (Number contents)+cEval1 (Closure _ (FloatExpr contents)) = return $ Value (Float contents)+cEval1 (Closure env (VarExpr name numExprs)) = do+ numVals <- mapM (eval env) numExprs+ nums <- mapM (\nVal -> case nVal of+ Number num -> return num+ _ -> throwError $ Default "cEval1: cannot reach here!")+ numVals+ objRef <- getVar env (name, nums)+ obj <- cRefEval1 objRef+ case obj of -- for Macro expansion+ Loop _ _ _ _ _ -> expandLoop env obj+ _ -> return obj+cEval1 (Closure env (InductiveDataExpr cons argExprs)) = do+ args <- liftIO $ mapM (makeClosure env) argExprs+ return $ Intermidiate $ IInductiveData cons args+cEval1 (Closure env (TupleExpr innerExprs)) = do+ innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs+ objRefs <- innerRefsToObjRefList innerRefs+ case objRefs of+ [objRef] -> cRefEval1 objRef+ _ -> return $ Intermidiate $ ITuple innerRefs+cEval1 (Closure env (CollectionExpr innerExprs)) = do+ innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs+ return $ Intermidiate $ ICollection innerRefs+cEval1 (Closure _ WildCardExpr) = return $ Value WildCard+cEval1 (Closure env (PatVarExpr name numExprs)) = do+ numVals <- mapM (eval env) numExprs+ nums <- mapM (\nVal -> case nVal of+ Number num -> return num+ _ -> throwError $ Default "cEval1: cannot reach here!")+ numVals+ return $ Value $ PatVar name nums+cEval1 (Closure env (PredPatExpr predName argExprs)) = do+ argObjRefs <- liftIO $ mapM (makeClosure env) argExprs+ return $ Value $ PredPat predName argObjRefs+cEval1 (Closure env (CutPatExpr patExpr)) = do+ patObjRef <- liftIO $ makeClosure env patExpr+ return $ Value $ CutPat patObjRef+cEval1 (Closure env (NotPatExpr patExpr)) = do+ patObjRef <- liftIO $ makeClosure env patExpr+ return $ Value $ NotPat patObjRef+cEval1 (Closure env (OrPatExpr patExprs)) = do+ patObjRefs <- liftIO $ mapM (makeClosure env) patExprs+ return $ Value $ OrPat patObjRefs+cEval1 (Closure env (AndPatExpr patExprs)) = do+ patObjRefs <- liftIO $ mapM (makeClosure env) patExprs+ return $ Value $ AndPat patObjRefs+cEval1 (Closure env (FuncExpr args body)) = do+ return $ Value $ Func args body env+cEval1 (Closure env (IfExpr condExpr expr1 expr2)) = do+ obj <- cEval1 $ Closure env condExpr+ case obj of+ Value (Bool True) -> cEval1 $ Closure env expr1+ Value (Bool False) -> cEval1 $ Closure env expr2+ _ -> throwError $ Default "if: condition is not bool value"+cEval1 (Closure env (LetExpr bindings body)) = do+ newEnv <- extendLet env bindings+ cEval1 (Closure newEnv body)+cEval1 (Closure env (LetRecExpr bindings body)) = do+ newEnv <- liftIO $ extendLetRec env bindings+ cEval1 $ Closure newEnv body+cEval1 (Closure env (DoExpr [] body)) = do+ cEval1 $ Closure env body+cEval1 (Closure env (DoExpr (binding:bindings) body)) = do+ newEnv <- extendLet env [binding]+ cEval1 $ Closure newEnv $ DoExpr bindings body+cEval1 (Closure env (TypeExpr bindings)) = do+ frameRef <- liftIO $ makeLetRecFrame env bindings+ frame <- liftIO $ readIORef frameRef+ return $ Value $ Type frame+cEval1 (Closure env (TypeRefExpr typExpr name)) = do+ obj <- cEval1 (Closure env typExpr)+ case obj of+ Value (Type frame) -> getVarFromFrame frame (name,[]) >>= cRefEval1+ _ -> throwError $ Default "type-ref: not type"+cEval1 (Closure env (DestructorExpr destructInfoExpr)) = do+ destructInfo <- liftIO $ makeDestructInfo destructInfoExpr+ return $ Value $ Destructor destructInfo+ where makeDestructInfo [] = return []+ makeDestructInfo ((cons, typExpr, pmcs):rest) = do+ typObjRef <- liftIO $ makeClosure env typExpr+ let epmcs = map (\(ppat, body) -> (env, ppat, body)) pmcs+ retRest <- makeDestructInfo rest+ return ((cons, typObjRef, epmcs):retRest)+cEval1 (Closure env (MatchAllExpr tgtExpr typExpr (patExpr, body))) = do+ patObjRef <- liftIO $ makeClosure env patExpr+ tgtObjRef <- liftIO $ makeClosure env tgtExpr+ typObjRef <- liftIO $ makeClosure env typExpr+ matchs <- patternMatch MAll [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]+ rets <- mapM (\match -> do newEnv <- liftIO $ extendEnv env match+ objRef <- liftIO $ newIORef (Closure newEnv body)+ return objRef)+ matchs+ return $ Intermidiate $ ICollection $ map IElement rets+cEval1 (Closure env (MatchExpr tgtExpr typExpr mcs)) = do+ tgtObjRef <- liftIO $ makeClosure env tgtExpr+ typObjRef <- liftIO $ makeClosure env typExpr+ retRef <- mcLoop tgtObjRef typObjRef mcs+ cRefEval1 retRef+ where mcLoop _ _ [] = throwError $ Default "end of match clauses"+ mcLoop tgtObjRef typObjRef ((patExpr, body):rest) = do+ patObjRef <- liftIO $ makeClosure env patExpr+ matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]+ case matchs of+ [match] -> do newEnv <- liftIO $ extendEnv env match+ objRef <- liftIO $ newIORef (Closure newEnv body)+ return objRef+ [] -> mcLoop tgtObjRef typObjRef rest+cEval1 (Closure env (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr)) = do+ rangeObjRef <- liftIO $ makeClosure env rangeExpr+ let loopObj = Loop loopVar indexVar rangeObjRef loopExpr tailExpr+ expandLoop env loopObj+cEval1 (Closure env (ApplyExpr opExpr argExpr)) = do+ op <- cEval1 (Closure env opExpr)+ case op of+ Value (IOFunc fn) -> do arg <- eval env argExpr+ val <- fn (tupleToList arg)+ return $ Value val+ Value (PrimitiveFunc fn) -> do arg <- eval env argExpr+ val <- liftThrows $ fn (tupleToList arg)+ return $ Value val+ Value (Func fArgs body cEnv) -> do frame <- liftIO (makeClosure env argExpr) >>= makeFrame fArgs+ newEnv <- liftIO $ extendEnv cEnv frame+ cEval1 (Closure newEnv body)+ _ -> throwError $ Default "not function"+cEval1 val = return val++cApply1 :: ObjectRef -> ObjectRef -> IOThrowsError Object+cApply1 fnObjRef argObjRef = do+ fnObj <- cRefEval1 fnObjRef+ case fnObj of+ Value (IOFunc fn) -> throwError $ Default "undefined ioFunc"+ Value (PrimitiveFunc fn) -> do arg <- cRefEval argObjRef+ val <- liftThrows $ fn (tupleToList arg)+ return $ Value val+ Value (Func fArgs body cEnv) -> do frame <- makeFrame fArgs argObjRef+ newEnv <- liftIO $ extendEnv cEnv frame+ cEval1 (Closure newEnv body)+ _ -> throwError $ Default "cApply1: not function"+++expandLoop :: Env -> Object -> IOThrowsError Object+expandLoop env (Loop loopVar indexVar rangeObjRef loopExpr tailExpr) = do+ b <- isEmptyCollection rangeObjRef+ if b+ then cEval1 $ Closure env tailExpr+ else do (carObjRef,cdrObjRef) <- consDestruct rangeObjRef+ loopObjRef <- liftIO $ newIORef $ Loop loopVar indexVar cdrObjRef loopExpr tailExpr+ newEnv <- liftIO $ extendEnv env [((loopVar,[]),loopObjRef),((indexVar,[]),carObjRef)]+ cEval1 $ Closure newEnv loopExpr+expandLoop _ obj = throwError $ Default $ "expandLoop: cannot reach here: " ++ show obj+ +-- |Extend given environment by binding a series of values to a new environment for let.+extendLet :: Env -- ^ Environment + -> [(Args, EgisonExpr)] -- ^ Extensions to the environment+ -> IOThrowsError Env -- ^ Extended environment+extendLet env abindings = do+ bingingList <- liftM concat $ mapM (\(args, expr) -> do+ objRef <- liftIO $ makeClosure env expr+ helper args objRef)+ abindings+ liftIO $ extendEnv env bingingList+ where helper (AVar name) objRef = return [((name, []), objRef)]+ helper (ATuple argss) objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ITuple innerRefs) -> do+ objRefs <- innerValRefsToObjRefList innerRefs+ liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs+ Value (Tuple innerVals) -> do+ objRefs <- liftIO $ mapM (newIORef . Value) $ innerValsToList innerVals+ liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs+ _ -> throwError $ Default "extendLet: not tuple"++makeFrame :: Args -> ObjectRef -> IOThrowsError [(Var, ObjectRef)]+makeFrame (AVar name) objRef = return $ [((name,[]), objRef)]+makeFrame (ATuple []) _ = return $ []+makeFrame (ATuple [fArg]) objRef = makeFrame fArg objRef+makeFrame (ATuple fArgs) objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ITuple innerRefs) -> do+ objRefs <- innerValRefsToObjRefList innerRefs+ frames <- mapM (\(fArg,objRef3) -> makeFrame fArg objRef3) $ zip fArgs objRefs+ return $ concat frames+ Value (Tuple innerVals) -> do+ let vals = innerValsToList innerVals+ objRefs <- liftIO $ valsToObjRefList vals+ frames <- mapM (\(fArg,objRef3) -> makeFrame fArg objRef3) $ zip fArgs objRefs+ return $ concat frames+ _ -> throwError $ Default "makeFrame: not tuple"++innerValRefsToObjRefList :: [InnerValRef] -> IOThrowsError [ObjectRef]+innerValRefsToObjRefList [] = return []+innerValRefsToObjRefList (innerRef:rest) = do+ restRet <- innerValRefsToObjRefList rest+ case innerRef of+ IElement objRef -> return $ objRef:restRet+ ISubCollection objRef -> do+ obj2 <- cRefEval1 objRef+ case obj2 of+ Intermidiate (ICollection innerRefs) -> do+ objRefs <- innerValRefsToObjRefList innerRefs+ return $ objRefs ++ restRet+ Value (Collection innerVals) -> do+ objRefs <- liftIO $ mapM newIORef $ map Value $ innerValsToList innerVals+ return $ objRefs ++ restRet+ _ -> throwError $ Default "innerValRefsToObjRefList: not collection"++patternMatch :: MatchFlag -> [MState] -> IOThrowsError [FrameList]+patternMatch _ [] = return []+patternMatch MAll ((MState frame []):rest) = do+ frames <- patternMatch MAll rest+ return (frame:frames)+patternMatch MOne ((MState frame []):_) = do+ return [frame]+patternMatch flag ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef)+ :atoms))+ :states) = do+ patObj <- liftIO $ readIORef patObjRef+ case patObj of+ Closure env expr ->+ do newEnv <- liftIO $ extendEnv env bf+ patObj2 <- cEval1 $ Closure newEnv expr+ patObjRef2 <- liftIO $ newIORef patObj2+ patternMatch flag ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef)+ :atoms))+ :states)+ Value WildCard -> patternMatch flag ((MState frame atoms):states)+ Value (PatVar name nums) -> do+ typ <- cRefEval1 typObjRef+ case typ of+ Value (Type tf) ->+ let mObjRef = Data.Map.lookup ("var-match",[]) tf in+ case mObjRef of+ Nothing -> throwError (Default "no method in type: var-match")+ Just fnObjRef ->+ do ret <- cApply1 fnObjRef tgtObjRef+ case ret of+ Intermidiate (ICollection innerObjRefs) -> do+ objRefs <- innerValRefsToObjRefList innerObjRefs+ patternMatch flag $ (map (\objRef -> (MState (((name,nums),objRef):frame)+ (map (\(MAtom (PClosure bf2 pat2) tgt2 typ2) ->+ (MAtom (PClosure (((name,nums),objRef):bf2) pat2) tgt2 typ2))+ atoms)))+ objRefs) ++ states+ _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"+ Intermidiate (IInductiveData con patObjRefs) -> do+ typObj <- cRefEval1 typObjRef+ case typObj of+ Value (Type tf) ->+ let mObjRef = Data.Map.lookup ("inductive-match",[]) tf in+ case mObjRef of+ Nothing -> throwError (Default "no method in type: inductiver-match")+ Just fnObjRef ->+ do fnObj <- cRefEval1 fnObjRef+ case fnObj of+ Value (Destructor deconInfo) -> do+ indRet <- inductiveMatch deconInfo con tgtObjRef+ case indRet of+ (nTypObjRef, nTgtsObjRef) -> do+ inTypObjRefs <- tupleToObjRefList nTypObjRef+ inTgtsRefs <- collectionToObjRefList nTgtsObjRef+ inTgtObjRefss <- mapM tupleToObjRefList inTgtsRefs+ patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))+ (zip3 patObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+ inTgtObjRefss) ++ states)+ _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"+ Value (InductiveData con pats) -> do+ patObjRefs <- liftIO $ mapM (newIORef . Value) pats+ typObj <- cRefEval1 typObjRef+ case typObj of+ Value (Type tf) ->+ let mObjRef = Data.Map.lookup ("inductive-match",[]) tf in+ case mObjRef of+ Nothing -> throwError (Default "no method in type: inductiver-match")+ Just fnObjRef ->+ do fnObj <- cRefEval1 fnObjRef+ case fnObj of+ Value (Destructor deconInfo) -> do+ indRet <- inductiveMatch deconInfo con tgtObjRef+ case indRet of+ (nTypObjRef, nTgtsObjRef) -> do+ inTypObjRefs <- tupleToObjRefList nTypObjRef+ inTgtsRefs <- collectionToObjRefList nTgtsObjRef+ inTgtObjRefss <- mapM tupleToObjRefList inTgtsRefs+ patternMatch flag $ (map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)+ (zip3 patObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+ inTgtObjRefss) ++ states+ _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"+ Intermidiate (ITuple pats) -> do+ patObjRefs <- innerRefsToObjRefList pats+ tgtObjRefs <- tupleToObjRefList tgtObjRef+ typObjRefs <- tupleToObjRefList typObjRef+ patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states+ Value (Tuple pats) -> do+ patObjRefs <- innerValsToObjRefList pats+ tgtObjRefs <- tupleToObjRefList tgtObjRef+ typObjRefs <- tupleToObjRefList typObjRef+ patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states+ Value (PredPat predName patObjRefs) -> do+ typObj <- cRefEval1 typObjRef+ case typObj of+ Value (Type tf) ->+ let mObjRef = Data.Map.lookup (predName,[]) tf in+ case mObjRef of+ Nothing -> throwError $ Default $ "no method in type: " ++ predName+ Just fnObjRef -> do+ argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ map IElement $ patObjRefs ++ [tgtObjRef]+ ret <- cApply1 fnObjRef argsObjRef+ case ret of+ Value (Bool True) -> patternMatch flag ((MState frame atoms):states)+ Value (Bool False) -> patternMatch flag states+ _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean value")+ _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"+ Value (NotPat patObjRef2) -> do+ retFrames <- patternMatch MOne [(MState frame [(MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef)])]+ case retFrames of+ [] -> patternMatch flag ((MState frame atoms):states)+ _ -> patternMatch flag states+ Value (AndPat patObjRefs) ->+ patternMatch flag ((MState frame ((map (\patObjRef2 -> (MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef)) patObjRefs) ++ atoms)):states)+ Value (OrPat patObjRefs) ->+ patternMatch flag ((map (\patObjRef2 -> (MState frame ((MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef):atoms)))+ patObjRefs) ++ states)+ Value (CutPat patObjRef2) -> do+ retFrames <- patternMatch flag [(MState frame ((MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef):atoms))]+ case retFrames of+ [] -> return []+ _ -> case flag of+ MAll -> do restFrames <- patternMatch flag states+ return (retFrames ++ restFrames)+ MOne -> return retFrames+ _ -> throwError $ Default $ "invalid pattern: " ++ show patObj+ +inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef,ObjectRef)+inductiveMatch [] _ _ = throwError (Default "inductiveMatch: not matched any clauses")+inductiveMatch ((con,_,[]):rest) pcon tgtObjRefRef =+ if (con == pcon)+ then throwError (Default "inductiveMatch: not matched any clauses")+ else inductiveMatch rest pcon tgtObjRefRef+inductiveMatch ((con,typObjRef,((env,ppat,expr):cls)):rest) pcon tgtObjRefRef =+ if (con == pcon)+ then do mPpmRet <- primitivePatternMatch ppat tgtObjRefRef+ case mPpmRet of+ Nothing -> inductiveMatch ((con,typObjRef,cls):rest) pcon tgtObjRefRef+ Just ppmRet -> do newEnv <- liftIO $ extendEnv env ppmRet+ ret <- liftIO $ makeClosure newEnv expr+ return (typObjRef,ret)+ else inductiveMatch rest pcon tgtObjRefRef+++primitivePatternMatch :: PrimitivePattern -> ObjectRef -> IOThrowsError (Maybe FrameList)+primitivePatternMatch (PPatBool bool) objRef = do+ val <- cRefEval objRef+ case val of+ Bool bool2 -> if bool == bool2+ then return (Just [])+ else return Nothing+ _ -> return Nothing+primitivePatternMatch (PPatChar chr) objRef = do+ val <- cRefEval objRef+ case val of+ Char chr2 -> if chr == chr2+ then return (Just [])+ else return Nothing+ _ -> return Nothing+primitivePatternMatch (PPatNumber num) objRef = do+ val <- cRefEval objRef+ case val of+ Number num2 -> if num == num2+ then return (Just [])+ else return Nothing+ _ -> return Nothing+primitivePatternMatch (PPatFloat d) objRef = do+ val <- cRefEval objRef+ case val of+ Float d2 -> if d == d2+ then return (Just [])+ else return Nothing+ _ -> return Nothing+primitivePatternMatch PWildCard _ = return $ Just []+primitivePatternMatch (PPatVar name) objRef = return (Just [((name,[]), objRef)])+primitivePatternMatch (PInductivePat pCons pPats) objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (IInductiveData cons objRefs) ->+ if pCons == cons+ then primitivePatternMatchList pPats objRefs+ else return Nothing+ _ -> return Nothing+primitivePatternMatch PEmptyPat objRef = do+ b <- isEmptyCollection objRef+ if b+ then return (Just [])+ else return Nothing+primitivePatternMatch (PConsPat carPat cdrPat) objRef = do+ b <- isEmptyCollection objRef+ if b+ then return Nothing+ else do (carObjRef, cdrObjRef) <- consDestruct objRef+ mCarFrame <- primitivePatternMatch carPat carObjRef+ case mCarFrame of+ Nothing -> return Nothing+ Just carFrame -> do mCdrFrame <- primitivePatternMatch cdrPat cdrObjRef+ case mCdrFrame of+ Nothing -> return Nothing+ Just cdrFrame -> return (Just (carFrame ++ cdrFrame))+primitivePatternMatch (PSnocPat rdcPat racPat) objRef = do+ b <- isEmptyCollection objRef+ if b+ then return Nothing+ else do (racObjRef, rdcObjRef) <- snocDestruct objRef+ mRacFrame <- primitivePatternMatch racPat racObjRef+ case mRacFrame of+ Nothing -> return Nothing+ Just racFrame -> do mRdcFrame <- primitivePatternMatch rdcPat rdcObjRef+ case mRdcFrame of+ Just rdcFrame -> return (Just (racFrame ++ rdcFrame))+ Nothing -> return Nothing+ +primitivePatternMatchList :: [PrimitivePattern] -> [ObjectRef] -> IOThrowsError (Maybe FrameList)+primitivePatternMatchList [] [] = return (Just [])+primitivePatternMatchList (pat:pats) (objRef:objRefs) = do+ mFrame <- primitivePatternMatch pat objRef+ case mFrame of+ Nothing -> return Nothing+ Just frame -> do mRestFrame <- primitivePatternMatchList pats objRefs+ case mRestFrame of+ Nothing -> return Nothing+ Just restFrame -> return (Just (frame ++ restFrame))+primitivePatternMatchList _ _ = throwError (Default "primitivePatternMatchList : number of patterns and targets are different")+++isEmptyCollection :: ObjectRef -> IOThrowsError Bool+isEmptyCollection objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ICollection innerRefs) -> isEmptyInnerRefs innerRefs+ Value (Collection innerVals) -> isEmptyInnerVals innerVals+ _ -> throwError $ Default $ "isEmptyCollection: not collection:" ++ show obj++isEmptyInnerRefs :: [InnerValRef] -> IOThrowsError Bool+isEmptyInnerRefs [] = return True+isEmptyInnerRefs ((IElement _):_) = return False+isEmptyInnerRefs ((ISubCollection objRef):rest) = do+ b <- isEmptyCollection objRef+ if b+ then isEmptyInnerRefs rest+ else return False++isEmptyInnerVals :: [InnerVal] -> IOThrowsError Bool+isEmptyInnerVals [] = return True+isEmptyInnerVals ((Element _):_) = return False+isEmptyInnerVals ((SubCollection val):rest) = do+ objRef <- liftIO $ newIORef $ Value val+ b <- isEmptyCollection objRef+ if b+ then isEmptyInnerVals rest+ else return False+++consDestruct :: ObjectRef -> IOThrowsError (ObjectRef, ObjectRef)+consDestruct objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ICollection innerRefs) -> consDestructInnerRefs innerRefs+ Value (Collection innerVals) -> consDestructInnerVals innerVals+ _ -> throwError $ Default "consDestruct: not collection"++consDestructInnerRefs :: [InnerValRef] -> IOThrowsError (ObjectRef, ObjectRef)+consDestructInnerRefs [] = throwError $ Default "consDestructInnerRefs: empty collection"+consDestructInnerRefs ((IElement objRef):rest) = do+ cdrObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection rest+ return (objRef, cdrObjRef)+consDestructInnerRefs ((ISubCollection objRef):rest) = do+ b <- isEmptyCollection objRef+ if b+ then consDestructInnerRefs rest+ else do (carObjRef, cdrObjRef) <- consDestruct objRef+ cdrObjRef2 <- liftIO $ newIORef $ Intermidiate $ ICollection $ (ISubCollection cdrObjRef):rest+ return (carObjRef, cdrObjRef2)+ +consDestructInnerVals :: [InnerVal] -> IOThrowsError (ObjectRef, ObjectRef)+consDestructInnerVals [] = throwError $ Default "consDestructInnerVals: empty collection"+consDestructInnerVals ((Element val):rest) = do+ carObjRef <- liftIO $ newIORef $ Value val+ cdrObjRef <- liftIO $ newIORef $ Value $ Collection rest+ return (carObjRef, cdrObjRef)+consDestructInnerVals ((SubCollection val):rest) = do+ objRef <- liftIO $ newIORef $ Value val+ b <- isEmptyCollection objRef+ if b+ then consDestructInnerVals rest+ else do (carObjRef, cdrObjRef) <- consDestruct objRef+ cdrObj <- liftIO $ readIORef cdrObjRef+ case cdrObj of+ Value (Collection innerVals) -> do+ cdrObjRef2 <- liftIO $ newIORef $ Value $ Collection $ (SubCollection (Collection innerVals)):rest+ return (carObjRef, cdrObjRef2)+ _ -> throwError $ Default "consDestructInnerVals: cannot reach here!"+++snocDestruct :: ObjectRef -> IOThrowsError (ObjectRef, ObjectRef)+snocDestruct objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ICollection innerRefs) -> snocDestructInnerRefs innerRefs+ Value (Collection innerVals) -> snocDestructInnerVals innerVals+ _ -> throwError $ Default "snocDestruct: not collection"++snocDestructInnerRefs :: [InnerValRef] -> IOThrowsError (ObjectRef, ObjectRef)+snocDestructInnerRefs [] = throwError $ Default "snocDestructInnerRefs: empty collection"+snocDestructInnerRefs ((IElement objRef):rest) = do+ cdrObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection rest+ return (objRef, cdrObjRef)+snocDestructInnerRefs ((ISubCollection objRef):rest) = do+ b <- isEmptyCollection objRef+ if b+ then snocDestructInnerRefs rest+ else do (carObjRef, cdrObjRef) <- snocDestruct objRef+ cdrObjRef2 <- liftIO $ newIORef $ Intermidiate $ ICollection $ (ISubCollection cdrObjRef):rest+ return (carObjRef, cdrObjRef2)+ +snocDestructInnerVals :: [InnerVal] -> IOThrowsError (ObjectRef, ObjectRef)+snocDestructInnerVals [] = throwError $ Default "snocDestructInnerVals: empty collection"+snocDestructInnerVals ((Element val):rest) = do+ carObjRef <- liftIO $ newIORef $ Value val+ cdrObjRef <- liftIO $ newIORef $ Value $ Collection rest+ return (carObjRef, cdrObjRef)+snocDestructInnerVals ((SubCollection val):rest) = do+ objRef <- liftIO $ newIORef $ Value val+ b <- isEmptyCollection objRef+ if b+ then snocDestructInnerVals rest+ else do (carObjRef, cdrObjRef) <- snocDestruct objRef+ cdrObj <- liftIO $ readIORef cdrObjRef+ case cdrObj of+ Value (Collection innerVals) -> do+ cdrObjRef2 <- liftIO $ newIORef $ Value $ Collection $ (SubCollection (Collection innerVals)):rest+ return (carObjRef, cdrObjRef2)+ _ -> throwError $ Default "snocDestructInnerVals: cannot reach here!"+++collectionToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]+collectionToObjRefList objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ICollection innerRefs) -> innerRefsToObjRefList innerRefs+ Value (Collection innerVals) -> innerValsToObjRefList innerVals+ _ -> throwError $ Default "collectionToObjRefList: not collection"++tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]+tupleToObjRefList objRef = do+ obj <- cRefEval1 objRef+ case obj of+ Intermidiate (ITuple innerRefs) -> innerRefsToObjRefList innerRefs+ Value (Tuple innerVals) -> innerValsToObjRefList innerVals+ _ -> throwError $ Default "tupleToObjRefList: not tuple"++innerRefsToObjRefList :: [InnerValRef] -> IOThrowsError [ObjectRef]+innerRefsToObjRefList [] = return []+innerRefsToObjRefList ((IElement objRef):rest) = do+ retRest <- innerRefsToObjRefList rest+ return $ objRef:retRest+innerRefsToObjRefList ((ISubCollection objRef):rest) = do+ retObj <- collectionToObjRefList objRef+ retRest <- innerRefsToObjRefList rest+ return $ retObj ++ retRest++innerValsToObjRefList :: [InnerVal] -> IOThrowsError [ObjectRef]+innerValsToObjRefList [] = return []+innerValsToObjRefList ((Element val):rest) = do+ valRef <- liftIO $ newIORef $ Value val+ retRest <- innerValsToObjRefList rest+ return $ valRef:retRest+innerValsToObjRefList ((SubCollection val):rest) = do+ valRef <- liftIO $ newIORef $ Value val+ retVal <- collectionToObjRefList valRef+ retRest <- innerValsToObjRefList rest+ return $ retVal ++ retRest++ +primitiveBindings :: IO Env+primitiveBindings = do+ initEnv <- nullEnv+ constantsFrameList <- mapM domakeObjRef constants+ iOFuncs <- mapM (domakeFunc IOFunc) ioPrimitives+ primitiveFuncs <- mapM (domakeFunc PrimitiveFunc) primitives+ extendEnv initEnv (constantsFrameList ++ iOFuncs ++ primitiveFuncs)+ where domakeFunc constructor (name, func) = do+ objRef <- newIORef $ Value $ constructor func+ return ((name, []), objRef)+ domakeObjRef (name, val) = do+ objRef <- newIORef $ Value val+ return ((name, []), objRef)+++constants :: [(String, EgisonVal)]+constants = [("pi", Float 3.14)+ ]+ +{- I/O primitives+Primitive functions that execute within the IO monad -}+ioPrimitives :: [(String, [EgisonVal] -> IOThrowsError EgisonVal)]+ioPrimitives = [("open-input-file", makePort ReadMode),+ ("open-output-file", makePort WriteMode),+ ("close-input-port", closePort),+ ("close-output-port", closePort),+ ("read-char", readChar),+ ("read-line", readLine),+ ("read", readFromStdin),+ ("write-char", writeChar),+ ("write-string", writeString),+ ("print", writeStringLine),+ ("write", write),+ ("flush", flushStdout),+ ("read-char-from-port", readCharFromPort),+ ("read-line-from-port", readLineFromPort),+ ("read-from-port", readFromPort),+ ("write-char-to-port", writeCharToPort),+ ("write-string-to-port", writeStringToPort),+ ("print-to-port", writeStringLineToPort),+ ("write-to-port", writeToPort),+ ("flush-port", flushPort)+ ]++{- "Pure" primitive functions -}+primitives :: [(String, [EgisonVal] -> ThrowsError EgisonVal)]+primitives = [("+", numericBinop (+)),+ ("-", numericBinop (-)),+ ("*", numericBinop (*)),+-- ("/", numericBinop (/)),+ ("mod", numericBinop mod),+ ("quotient", numericBinop quot),+ ("remainder", numericBinop rem),++ ("+f", floatBinop (+)),+ ("-f", floatBinop (-)),+ ("*f", floatBinop (*)),+ ("/f", floatBinop (/)),++ ("round", floatNumSglop round),+ ("floor", floatNumSglop floor),+ ("ceiling", floatNumSglop ceiling),+ ("truncate", floatNumSglop truncate),++ ("exp", numExp),+ ("log", numLog),++ ("sin", floatSglop sin),+ ("cos", floatSglop cos),+ ("tan", floatSglop tan),+ ("asin", floatSglop asin),+ ("acos", floatSglop acos),+ ("atan", floatSglop atan),+ ("sinh", floatSglop sinh),+ ("cosh", floatSglop cosh),+ ("tanh", floatSglop tanh),+ ("asinh", floatSglop asinh),+ ("acosh", floatSglop acosh),+ ("atanh", floatSglop atanh),++ ("sqrt", numSqrt),+ ("expt", numExpt),++ ("eq?", numBoolBinop (==)),+ ("lt?", numBoolBinop (<)),+ ("lte?", numBoolBinop (<=)),+ ("gt?", numBoolBinop (>)),+ ("gte?", numBoolBinop (>=)),++ ("eq-f?", floatBoolBinop (==)),+ ("lt-f?", floatBoolBinop (<)),+ ("lte-f?", floatBoolBinop (<=)),+ ("gt-f?", floatBoolBinop (>)),+ ("gte-f?", floatBoolBinop (>=)),++ ("&&", boolBinop (&&)),+ ("||", boolBinop (||))]+
+ hs-src/Language/Egison/Numerical.hs view
@@ -0,0 +1,156 @@+module Language.Egison.Numerical (+ boolBinop+ , numericSglop + , floatSglop+ , floatNumSglop+ , numericBinop+ , floatBinop+ , numBoolBinop+ , floatBoolBinop+-- , foldlM+-- , foldl1M+ , floatFloor+ , floatCeiling+ , floatTruncate+ , floatRound+ , numExpt+ , numSqrt+ , numExp+ , numLog+-- , numToString+-- , floatToString+ , unpackBool+ , unpackNum+ , unpackFloat+) where+import Language.Egison.Types++import Control.Monad.Error+--import Data.Char hiding (isNumber)+--import Data.Fixed+--import Numeric+--import Text.Printf++boolBinop :: (Bool -> Bool -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal+boolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+boolBinop op aparams = mapM unpackBool aparams >>= return . Bool . foldl1 op++numericSglop :: (Integer -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal+numericSglop op [x] = unpackNum x >>= return . Number . op+numericSglop _ params = throwError $ NumArgs 1 params++floatSglop :: (Double -> Double) -> [EgisonVal] -> ThrowsError EgisonVal+floatSglop op [x] = unpackFloat x >>= return . Float . op+floatSglop _ params = throwError $ NumArgs 1 params++floatNumSglop :: (Double -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal+floatNumSglop op [x] = unpackFloat x >>= return . Number . op+floatNumSglop _ params = throwError $ NumArgs 1 params++numericBinop :: (Integer -> Integer -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal+numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op++floatBinop :: (Double -> Double -> Double) -> [EgisonVal] -> ThrowsError EgisonVal+floatBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+floatBinop op aparams = mapM unpackFloat aparams >>= return . Float . foldl1 op++numBoolBinop :: (Integer -> Integer -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal+numBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+numBoolBinop op aparams = mapM unpackNum aparams >>= doOp+ where doOp [a, b] = return $ Bool $ op a b+ doOp _ = throwError $ Default "Unexpected error in numBoolBinop"+++floatBoolBinop :: (Double -> Double -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal+floatBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal+floatBoolBinop op aparams = mapM unpackFloat aparams >>= doOp+ where doOp [a, b] = return $ Bool $ op a b+ doOp _ = throwError $ Default "Unexpected error in floatBoolBinop"++-- - Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs+foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a+foldlM f v (x : xs) = (f v x) >>= \ a -> foldlM f a xs+foldlM _ v [] = return v++foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a+foldl1M f (x : xs) = foldlM f x xs+foldl1M _ _ = error "Unexpected error in foldl1M"+-- end GenUtil++floatRound, floatFloor, floatCeiling, floatTruncate :: [EgisonVal] -> ThrowsError EgisonVal+floatRound [(Float n)] = return $ Float $ fromInteger $ round n+floatRound [x] = throwError $ TypeMismatch "floatber" x+floatRound badArgList = throwError $ NumArgs 1 badArgList++floatFloor [(Float n)] = return $ Float $ fromInteger $ floor n+floatFloor [x] = throwError $ TypeMismatch "number" x+floatFloor badArgList = throwError $ NumArgs 1 badArgList++floatCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n+floatCeiling [x] = throwError $ TypeMismatch "number" x+floatCeiling badArgList = throwError $ NumArgs 1 badArgList++floatTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n+floatTruncate [x] = throwError $ TypeMismatch "number" x+floatTruncate badArgList = throwError $ NumArgs 1 badArgList++numSqrt, numExpt :: [EgisonVal] -> ThrowsError EgisonVal+numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n+ else throwError $ Default "negative number to sqrt"+numSqrt [x] = throwError $ TypeMismatch "number" x+numSqrt badArgList = throwError $ NumArgs 1 badArgList++numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p+numExpt [(Float n), (Number p)] = return $ Float $ n ^ p+numExpt [_, y] = throwError $ TypeMismatch "integer" y+numExpt badArgList = throwError $ NumArgs 2 badArgList++numExp :: [EgisonVal] -> ThrowsError EgisonVal+numExp [(Number n)] = return $ Float $ exp $ fromInteger n+numExp [(Float n)] = return $ Float $ exp n+numExp [x] = throwError $ TypeMismatch "number" x+numExp badArgList = throwError $ NumArgs 1 badArgList++numLog :: [EgisonVal] -> ThrowsError EgisonVal+numLog [(Number n)] = return $ Float $ log $ fromInteger n+numLog [(Float n)] = return $ Float $ log n+numLog [x] = throwError $ TypeMismatch "number" x+numLog badArgList = throwError $ NumArgs 1 badArgList++-- |Convert a number to a string; radix is optional, defaults to base 10+--numToString :: [EgisonVal] -> IOThrowsError EgisonVal+--numToString [(Number n), (Number radix)] = do+-- case radix of+-- 2 -> do -- Nice tip from StackOverflow question #1959715+-- liftIO $ stringToCharCollection $ showIntAtBase 2 intToDigit n ""+-- 8 -> liftIO $ stringToCharCollection $ printf "%o" n+-- 10 -> liftIO $ stringToCharCollection $ printf "%d" n+-- 16 -> liftIO $ stringToCharCollection $ printf "%x" n+-- _ -> throwError $ BadSpecialForm "Invalid radix value" $ Number radix++-- |Convert a float to a string; radix is optional, defaults to base 10+--floatToString :: [EgisonVal] -> IOThrowsError EgisonVal+--floatToString [(Float n)] = liftIO $ stringToCharCollection $ show n+--floatToString [x] = throwError $ TypeMismatch "number" x+--floatToString badArgList = throwError $ NumArgs 1 badArgList++-- - end Numeric operations section++-- |Extract an integer from the given value, throwing a type error if+-- the wrong type is passed.+unpackBool :: EgisonVal -> ThrowsError Bool+unpackBool (Bool b) = return b+unpackBool notBool = throwError $ TypeMismatch "bool" notBool++-- |Extract an integer from the given value, throwing a type error if+-- the wrong type is passed.+unpackNum :: EgisonVal -> ThrowsError Integer+unpackNum (Number n) = return n+unpackNum notNum = throwError $ TypeMismatch "number" notNum++-- |Extract an double from the given value, throwing a type error if+-- the wrong type is passed.+unpackFloat :: EgisonVal -> ThrowsError Double+unpackFloat (Float n) = return n+unpackFloat notFloat = throwError $ TypeMismatch "float" notFloat
+ hs-src/Language/Egison/Parser.hs view
@@ -0,0 +1,490 @@+module Language.Egison.Parser where+import Language.Egison.Types+import Control.Monad.Error+import qualified Data.Char as Char+import Data.Complex+import Data.Array+import Numeric+import Data.Ratio+import Text.ParserCombinators.Parsec hiding (spaces)+import Text.Parsec.Language+import Text.Parsec.Prim (ParsecT)+import qualified Text.Parsec.Token as P++egisonDef :: LanguageDef ()+egisonDef + = emptyDef + { P.commentStart = "#|"+ , P.commentEnd = "|#"+ , P.commentLine = ";"+ , P.nestedComments = True+ , P.identStart = letter <|> symbol+ , P.identLetter = letter <|> digit <|> symbol <|> symbol2+ , P.reservedNames = []+ , P.caseSensitive = True+ } ++--lexer :: P.GenTokenParser String () Identity+lexer = P.makeTokenParser egisonDef++--dot :: ParsecT String () Identity String+dot = P.dot lexer++--parens :: ParsecT String () Identity a -> ParsecT String () Identity a+parens = P.parens lexer++brackets = P.brackets lexer++braces = P.braces lexer++angles = P.angles lexer++--identifier :: ParsecT String () Identity String+identifier = P.identifier lexer++-- TODO: typedef. starting point was: whiteSpace :: CharParser ()+--whiteSpace :: ParsecT String () Identity ()+whiteSpace = P.whiteSpace lexer++--lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a+lexeme = P.lexeme lexer++symbol :: Parser Char+--symbol = oneOf "!$%&|*+-/:<=>?@^_~."+symbol = oneOf "%&|*+-/:="++symbol2 :: Parser Char+--symbol = oneOf "!$%&|*+-/:<=>?@^_~."+symbol2 = oneOf "!?"++parseBool :: Parser EgisonExpr+parseBool = do _ <- string "#"+ x <- oneOf "tf"+ return $ case x of+ 't' -> BoolExpr True+ 'f' -> BoolExpr False+ _ -> BoolExpr False++parseBool2 :: Parser Bool+parseBool2 = do+ boolExpr <- parseBool+ case boolExpr of+ BoolExpr True -> return True+ BoolExpr False -> return False+ +parseChar :: Parser EgisonExpr+parseChar = do+ _ <- char '\''+ x <- parseEscapedChar <|> noneOf ("'")+ _ <- char '\''+ return $ CharExpr x+ +parseChar2 :: Parser Char+parseChar2 = do chrExpr <- parseChar+ case chrExpr of+ CharExpr chr -> return chr++parseOctalNumber :: Parser EgisonExpr+parseOctalNumber = do+ _ <- try (string "#o")+ sign <- many (oneOf "-")+ num <- many1 (oneOf "01234567")+ case (length sign) of+ 0 -> return $ NumberExpr $ fst $ Numeric.readOct num !! 0+ 1 -> return $ NumberExpr $ fromInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0+ _ -> pzero++parseBinaryNumber :: Parser EgisonExpr+parseBinaryNumber = do+ _ <- try (string "#b")+ sign <- many (oneOf "-")+ num <- many1 (oneOf "01")+ case (length sign) of+ 0 -> return $ NumberExpr $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0+ 1 -> return $ NumberExpr $ fromInteger $ (*) (-1) $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0+ _ -> pzero++parseHexNumber :: Parser EgisonExpr+parseHexNumber = do+ _ <- try (string "#x")+ sign <- many (oneOf "-")+ num <- many1 (digit <|> oneOf "abcdefABCDEF")+ case (length sign) of+ 0 -> return $ NumberExpr $ fst $ Numeric.readHex num !! 0+ 1 -> return $ NumberExpr $ fromInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0+ _ -> pzero++-- |Parser for Integer, base 10+parseDecimalNumber :: Parser EgisonExpr+parseDecimalNumber = do+ _ <- try (many (string "#d"))+ sign <- many (oneOf "-")+ num <- many1 (digit)+ if (length sign) > 1+ then pzero+ else return $ (NumberExpr . read) $ sign ++ num++-- |Parser for a base 10 Integer that will also+-- check to see if the number is followed by+-- an exponent (scientific notation). If so,+-- the integer is converted to a float of the+-- given magnitude.+parseDecimalNumberMaybeExponent :: Parser EgisonExpr+parseDecimalNumberMaybeExponent = do+ num <- parseDecimalNumber+ result <- parseNumberExponent num+ return result++-- |Parse an integer in any base+parseNumber :: Parser EgisonExpr+parseNumber = parseDecimalNumberMaybeExponent <|>+ parseHexNumber <|>+ parseBinaryNumber <|>+ parseOctalNumber <?>+ "Unable to parse number"++parseNumber2 :: Parser Integer+parseNumber2 = do numExpr <- parseNumber+ case numExpr of+ NumberExpr n -> return n+ +-- |Parse a floating point number+parseRealNumber :: Parser EgisonExpr+parseRealNumber = do+ sign <- many (oneOf "-+")+ num <- many1 (digit)+ _ <- char '.'+ frac <- many1 (digit)+ let dec = num ++ "." ++ frac+ f <- case (length sign) of+ 0 -> return $ FloatExpr $ fst $ Numeric.readFloat dec !! 0+ -- Bit of a hack, but need to support the + sign as well as the minus.+ 1 -> if sign == "-" + then return $ FloatExpr $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0+ else return $ FloatExpr $ fst $ Numeric.readFloat dec !! 0+ _ -> pzero+ result <- parseNumberExponent f+ return result++parseRealNumber2 :: Parser Double+parseRealNumber2 = do floatExpr <- parseRealNumber+ case floatExpr of+ FloatExpr d -> return d+ +-- | Parse the exponent section of a floating point number+-- in scientific notation. Eg "e10" from "1.0e10"+parseNumberExponent :: EgisonExpr -> Parser EgisonExpr+parseNumberExponent n = do + exp <- many $ oneOf "Ee"+ case (length exp) of+ 0 -> return n+ 1 -> do+ num <- try (parseDecimalNumber)+ case num of+ NumberExpr exp -> buildResult n exp+ _ -> pzero+ _ -> pzero+ where + buildResult (NumberExpr num) exp = return $ FloatExpr $ (fromIntegral num) * (10 ** (fromIntegral exp))+ buildResult (FloatExpr num) exp = return $ FloatExpr $ num * (10 ** (fromIntegral exp))+ buildResult num _ = pzero++parseEscapedChar :: GenParser Char st Char+parseEscapedChar = do+ _ <- char '\\'+ c <- anyChar+ return $ case c of+ 'n' -> '\n'+ 't' -> '\t'+ 'r' -> '\r'+ _ -> c++parseString2 :: Parser String+parseString2 = do+ _ <- char '"'+ x <- many (parseEscapedChar <|> noneOf ("\""))+ _ <- char '"'+ return $ x++parseString :: Parser EgisonExpr+parseString = do+ x <- parseString2+ return $ StringExpr x++parseIndexNums :: Parser [EgisonExpr]+parseIndexNums = do try (do char '_'+ n <- parseExpr+ ns <- parseIndexNums+ return (n:ns))+ <|> do return []++parseInnerExp :: Parser InnerExpr+parseInnerExp = do v <- lexeme parseExpr+ return $ ElementExpr v+ <|> do char '@'+ v <- lexeme parseExpr+ return $ SubCollectionExpr v++parsePatVar2 :: Parser VarExpr+parsePatVar2 = do char '$'+ name <- identifier+ nums <- parseIndexNums+ return (name, nums)++parsePatVar :: Parser EgisonExpr+parsePatVar = do (name, nums) <- parsePatVar2+ return $ PatVarExpr name nums+ +parseSymbol2 :: Parser VarExpr+parseSymbol2 = do char '#'+ name <- identifier+ nums <- lexeme parseIndexNums+ return (name, nums)++parseSymbol :: Parser EgisonExpr+parseSymbol = do (name, nums) <- parseSymbol2+ return $ SymbolExpr name nums+ +parseArgs :: Parser ArgsExpr+parseArgs = do+ try (do (name, _) <- lexeme parsePatVar2+ return $ AVar name)+ <|> try (lexeme (brackets (do args <- sepEndBy parseArgs whiteSpace+ return $ ATuple args)))+ +parseBindings :: Parser Bindings+parseBindings = do+ braces (do sepEndBy (brackets (do args <- lexeme parseArgs+ expr <- lexeme parseExpr+ return (args, expr)))+ whiteSpace)++parseRecursiveBindings :: Parser RecursiveBindings+parseRecursiveBindings = do+ braces (do sepEndBy (brackets (do char '$'+ name <- lexeme identifier+ expr <- lexeme parseExpr+ return (name, expr)))+ whiteSpace)++parseVar :: Parser EgisonExpr+parseVar = do name <- identifier+ nums <- lexeme parseIndexNums+ return $ VarExpr name nums++parseWildCard :: Parser EgisonExpr+parseWildCard = do char '_'+ return WildCardExpr++parseCutPat :: Parser EgisonExpr+parseCutPat = do char '!'+ expr <- parseExpr+ return $ CutPatExpr expr++parseNotPat :: Parser EgisonExpr+parseNotPat = do char '^'+ expr <- parseExpr+ return $ CutPatExpr expr++parseValuePat :: Parser EgisonExpr+parseValuePat = do char ','+ expr <- parseExpr+ return $ PredPatExpr "=" [expr]++parseInnerExpr :: Parser InnerExpr+parseInnerExpr = do expr <- parseExpr+ return $ ElementExpr expr+ <|> do char '@'+ expr <- parseExpr+ return $ SubCollectionExpr expr++parsePattern :: Parser EgisonExpr+parsePattern =+ parseWildCard+ <|> parsePatVar+ <|> parseCutPat+ <|> parseNotPat+ <|> parseValuePat+ <|> parens (do try (char '?' >> many1 space)+ predName <- lexeme identifier+ argExprs <- sepEndBy parseExpr whiteSpace+ return (PredPatExpr predName argExprs)+ <|> do try (char '|' >> many1 space)+ pats <- sepEndBy parseExpr whiteSpace+ return (OrPatExpr pats)+ <|> do try (char '&' >> many1 space)+ pats <- sepEndBy parseExpr whiteSpace+ return (AndPatExpr pats))+++parseDestructInfoExpr :: Parser DestructInfoExpr+parseDestructInfoExpr = braces (sepEndBy parseDestructClause whiteSpace)++parseDestructClause :: Parser (String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])+parseDestructClause = brackets (do patCons <- lexeme identifier+ typExpr <- lexeme parseExpr+ dc2s <- lexeme (braces (sepEndBy parseDestructClause2 whiteSpace))+ return (patCons, typExpr, dc2s))++parseDestructClause2 :: Parser (PrimitivePattern, EgisonExpr)+parseDestructClause2 = brackets (do datPat <- lexeme parsePrimitivePattern+ expr <- lexeme parseExpr+ return (datPat, expr))++parsePrimitivePattern :: Parser PrimitivePattern+parsePrimitivePattern =+ do char '_'+ return PWildCard+ <|> do char '$'+ name <- identifier+ return (PPatVar name)+ <|> angles (do c <- lexeme identifier+ ps <- sepEndBy parsePrimitivePattern whiteSpace+ return (PInductivePat c ps))+ <|> try (do string "{}"+ return PEmptyPat)+ <|> try (do lexeme $ char '{'+ a <- lexeme parsePrimitivePattern+ char '.'+ b <- lexeme parsePrimitivePattern+ char '}'+ return (PConsPat a b))+ <|> try (do lexeme $ char '{'+ char '.'+ a <- lexeme parsePrimitivePattern+ b <- lexeme parsePrimitivePattern+ char '}'+ return (PSnocPat a b))+ <|> do b <- try parseBool2+ return (PPatBool b)+ <|> do c <- try parseChar2+ return (PPatChar c)+ <|> do d <- try parseRealNumber2+ return (PPatFloat d)+ <|> do n <- try parseNumber2+ return (PPatNumber n)++parseMatchClause :: Parser MatchClause+parseMatchClause = brackets (do pat <- lexeme parseExpr+ body <- lexeme parseExpr+ return (pat, body))+ +-- |Parse an expression+parseExpr :: Parser EgisonExpr+parseExpr =+ try (lexeme parseRealNumber)+ <|> try (lexeme parseNumber)+ <|> lexeme parseChar+ <|> lexeme parseString+ <|> try (lexeme parseBool)+ <|> try (lexeme parseSymbol)+ <|> try (lexeme parsePattern)+-- <|> lexeme parsePatVarOmitExpr+ <|> lexeme parseVar+ <|> angles (do cons <- lexeme identifier+ argExprs <- sepEndBy parseExpr whiteSpace+ return $ InductiveDataExpr cons argExprs)+ <|> braces (do innerExprs <- sepEndBy parseInnerExpr whiteSpace+ return $ CollectionExpr innerExprs)+ <|> brackets (do innerExprs <- sepEndBy parseInnerExpr whiteSpace+ return $ TupleExpr innerExprs)+ <|> parens (do try (string "lambda" >> many1 space)+ args <- lexeme parseArgs+ body <- lexeme parseExpr+ return (FuncExpr args body)+ <|> do try (string "if" >> many1 space)+ condExpr <- lexeme parseExpr+ expr1 <- lexeme parseExpr+ expr2 <- lexeme parseExpr+ return (IfExpr condExpr expr1 expr2)+ <|> do try (string "letrec" >> many1 space)+ bindings <- lexeme parseRecursiveBindings+ body <- lexeme parseExpr+ return (LetRecExpr bindings body)+ <|> do try (string "let" >> many1 space)+ bindings <- lexeme parseBindings+ body <- lexeme parseExpr+ return (LetExpr bindings body)+ <|> do try (string "do" >> many1 space)+ bindings <- lexeme parseBindings+ body <- lexeme parseExpr+ return (DoExpr bindings body)+ <|> do try (string "type-ref" >> many1 space)+ typExpr <- lexeme parseExpr+ name <- lexeme identifier+ return (TypeRefExpr typExpr name)+ <|> do try (string "type" >> many1 space)+ bindings <- lexeme parseRecursiveBindings+ return (TypeExpr bindings)+ <|> do try (string "destructor" >> many1 space)+ deconsInfo <- lexeme parseDestructInfoExpr+ return (DestructorExpr deconsInfo)+ <|> do try (string "match-all" >> many1 space)+ tgtExpr <- lexeme parseExpr+ typExpr <- lexeme parseExpr+ mc <- lexeme parseMatchClause+ return (MatchAllExpr tgtExpr typExpr mc)+ <|> do try (string "match" >> many1 space)+ tgtExpr <- lexeme parseExpr+ typExpr <- lexeme parseExpr+ mcs <- braces (sepEndBy parseMatchClause whiteSpace)+ return (MatchExpr tgtExpr typExpr mcs)+ <|> do try (string "loop" >> many1 space)+ (loopVar, _) <- lexeme parsePatVar2+ (indexVar, _) <- lexeme parsePatVar2+ rangeExpr <- lexeme parseExpr+ loopExpr <- lexeme parseExpr+ tailExpr <- lexeme parseExpr+ return (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr)+ <|> do opExpr <- lexeme parseExpr+ argExprs <- sepEndBy parseExpr whiteSpace+ return (ApplyExpr opExpr (TupleExpr (map ElementExpr argExprs))))+ <?> "Expression"++parseTopExpr :: Parser TopExpr+parseTopExpr =+ do whiteSpace+ parens (do try $ lexeme $ string "define"+ char '$'+ name <- lexeme identifier+ expr <- lexeme parseExpr+ return (Define name expr)+ <|> do try $ lexeme $ string "test"+ expr <- lexeme parseExpr+ return (Test expr)+ <|> do try $ lexeme $ string "execute"+ args <- sepEndBy parseString2 whiteSpace+ return (Execute args)+ <|> do try $ string "load-file" >> many1 space+ filename <- lexeme parseString2+ return (LoadFile filename)+ <|> do try $ lexeme $ string "load"+ filename <- lexeme parseString2+ return (Load filename)+ ) <?> "top expression"++mainParser :: Parser TopExpr+mainParser = do+ x <- parseTopExpr+-- FUTURE? (seemed to break test cases, but is supposed to be best practice?) eof+ return x++-- |Use a parser to parse the given text, throwing an error+-- if there is a problem parsing the text.+readOrThrow :: Parser a -> String -> ThrowsError a+readOrThrow parser input = case parse parser "egison" input of+ Left err -> throwError $ Parser err+ Right val -> return val++-- |Parse an top expression from a string of text+readTopExpr :: String -> ThrowsError TopExpr+readTopExpr = readOrThrow mainParser++-- |Parse an expression from a string of text+readExpr :: String -> ThrowsError EgisonExpr+readExpr = readOrThrow parseExpr++-- |Parse many top expressions from a string of text+readTopExprList :: String -> ThrowsError [TopExpr]+readTopExprList = readOrThrow (endBy mainParser whiteSpace)+
+ hs-src/Language/Egison/Primitives.hs view
@@ -0,0 +1,203 @@+module Language.Egison.Primitives where+import Language.Egison.Numerical+import Language.Egison.Parser+import Language.Egison.Types+import qualified Control.Exception+import Control.Monad.Error+import Data.Char hiding (isSymbol)+import Data.Array+import Data.Unique+import qualified Data.Map+import System.IO+import System.Directory (doesFileExist, removeFile)+import System.IO.Error++---------------------------------------------------+-- I/O Primitives+-- These primitives all execute within the IO monad+---------------------------------------------------+makePort :: IOMode -> [EgisonVal] -> IOThrowsError EgisonVal+makePort mode [(World actions), (String filename)] = do+ port <- liftM (Port filename) $ liftIO $ openFile filename mode+ let newWorld = case mode of+ ReadMode -> World $ (OpenInputPort filename):actions+ WriteMode -> World $ (OpenOutputPort filename):actions+ return $ makeTupleFromValList [newWorld, port]+makePort _ [] = throwError $ NumArgs 2 []+makePort _ [arg] = throwError $ NumArgs 2 [arg]+makePort _ args@(_:_:_:_) = throwError $ NumArgs 2 args+makePort _ _ = throwError $ Default $ "closePort: invalid arguments"++closePort :: [EgisonVal] -> IOThrowsError EgisonVal+closePort [World actions, Port filename port] = do+ liftIO $ hClose port+ let newWorld = World $ (ClosePort filename):actions+ return newWorld+closePort _ = throwError $ Default $ "closePort: invalid arguments"++writeChar :: [EgisonVal] -> IOThrowsError EgisonVal+writeChar [World actions, Char c] = do+ liftIO $ putChar c+ let newWorld = World $ (WriteToPort "stdout" [c]):actions+ return newWorld+writeChar _ = throwError $ Default $ "writeChar: invalid arguments"++writeString :: [EgisonVal] -> IOThrowsError EgisonVal+writeString [World actions, String str] = do+ liftIO $ putStr str+ let newWorld = World $ (WriteToPort "stdout" str):actions+ return newWorld+writeString _ = throwError $ Default $ "writeString: invalid arguments"++writeStringLine :: [EgisonVal] -> IOThrowsError EgisonVal+writeStringLine [World actions, String str] = do+ liftIO $ putStrLn str+ let newWorld = World $ (WriteToPort "stdout" str):actions+ return newWorld+writeStringLine _ = throwError $ Default $ "writeStringLine: invalid arguments"++write :: [EgisonVal] -> IOThrowsError EgisonVal+write [World actions, val] = do+ let str = show val+ liftIO $ putStr str+ let newWorld = World $ (WriteToPort "stdout" str):actions+ return newWorld+write _ = throwError $ Default $ "write: invalid arguments"++flushStdout :: [EgisonVal] -> IOThrowsError EgisonVal+flushStdout [World actions] = do+ liftIO $ hFlush stdout+ let newWorld = World $ (FlushPort "stdout"):actions+ return newWorld+flushStdout _ = throwError $ Default $ "flush: invalid arguments"++readChar :: [EgisonVal] -> IOThrowsError EgisonVal+readChar [World actions] = do+ c <- liftIO $ getChar+ let newWorld = World $ (ReadFromPort "stdin" [c]):actions+ return $ makeTupleFromValList [newWorld, Char c]+readChar _ = throwError $ Default $ "readChar: invalid arguments"++readLine :: [EgisonVal] -> IOThrowsError EgisonVal+readLine [World actions] = do+ str <- liftIO $ getLine+ let newWorld = World $ (ReadFromPort "stdin" str):actions+ return $ makeTupleFromValList [newWorld, String str]+readLine _ = throwError $ Default $ "readLine: invalid arguments"++readFromStdin :: [EgisonVal] -> IOThrowsError EgisonVal+readFromStdin [World actions] = do+ str <- liftIO $ hGetExpr stdin+ let newWorld = World $ (ReadFromPort "stdin" str):actions+ expr <- liftThrows $ readExpr str+ val <- liftThrows $ exprToVal expr+ return $ makeTupleFromValList [newWorld, val]+readFromStdin _ = throwError $ Default $ "read: invalid arguments"+++writeCharToPort :: [EgisonVal] -> IOThrowsError EgisonVal+writeCharToPort [World actions, Port filename port, Char c] = do+ liftIO $ hPutChar port c+ let newWorld = World $ (WriteToPort filename [c]):actions+ return newWorld+writeCharToPort _ = throwError $ Default $ "writeCharToPort: invalid arguments"++writeStringToPort :: [EgisonVal] -> IOThrowsError EgisonVal+writeStringToPort [World actions, Port filename port, String str] = do+ liftIO $ hPutStr port str+ let newWorld = World $ (WriteToPort filename str):actions+ return newWorld+writeStringToPort _ = throwError $ Default $ "writeString: invalid arguments"++writeStringLineToPort :: [EgisonVal] -> IOThrowsError EgisonVal+writeStringLineToPort [World actions, Port filename port, String str] = do+ liftIO $ hPutStrLn port str+ let newWorld = World $ (WriteToPort filename str):actions+ return newWorld+writeStringLineToPort _ = throwError $ Default $ "writeStringLineToPort: invalid arguments"++writeToPort :: [EgisonVal] -> IOThrowsError EgisonVal+writeToPort [World actions, Port filename port, val] = do+ let str = show val+ liftIO $ hPutStr port str+ let newWorld = World $ (WriteToPort filename str):actions+ return newWorld+writeToPort _ = throwError $ Default $ "writeToPort: invalid arguments"++flushPort :: [EgisonVal] -> IOThrowsError EgisonVal+flushPort [World actions, Port filename port] = do+ liftIO $ hFlush port+ let newWorld = World $ (FlushPort filename):actions+ return newWorld+flushPort _ = throwError $ Default $ "flush-port: invalid arguments"++readCharFromPort :: [EgisonVal] -> IOThrowsError EgisonVal+readCharFromPort [World actions, Port filename port] = do+ c <- liftIO $ hGetChar port+ let newWorld = World $ (ReadFromPort filename [c]):actions+ return $ makeTupleFromValList [newWorld, Char c]+readCharFromPort _ = throwError $ Default $ "readCharFromPort: invalid arguments"++readLineFromPort :: [EgisonVal] -> IOThrowsError EgisonVal+readLineFromPort [World actions, Port filename port] = do+ str <- liftIO $ hGetLine port+ let newWorld = World $ (ReadFromPort filename str):actions+ return $ makeTupleFromValList [newWorld, String str]+readLineFromPort _ = throwError $ Default $ "readLineFromPort: invalid arguments"++readFromPort :: [EgisonVal] -> IOThrowsError EgisonVal+readFromPort [World actions, Port filename port] = do+ str <- liftIO $ hGetExpr port+ let newWorld = World $ (ReadFromPort filename str):actions+ expr <- liftThrows $ readExpr str+ val <- liftThrows $ exprToVal expr+ return $ makeTupleFromValList [newWorld, val]+readFromPort _ = throwError $ Default $ "read: invalid arguments"+++hGetExpr :: Handle -> IO String+hGetExpr h = do+ str <- loop ""+ return str+ where+ loop :: String -> IO String+ loop input0 = do+ input <- hGetLine h+ let newInput = input0 ++ input+ if countParens newInput+ then return newInput+ else loop newInput++countParens :: String -> Bool+countParens str = let countOpen = length $ filter (\c -> ('(' == c)+ || ('{' == c)+ || ('[' == c)+ || ('<' == c))+ str in+ let countClose = length $ filter (\c -> (')' == c)+ || ('}' == c)+ || (']' == c)+ || ('>' == c))+ str in+ (countOpen == countClose)++exprToVal :: EgisonExpr -> ThrowsError EgisonVal+exprToVal (BoolExpr contents) = return $ Bool contents+exprToVal (CharExpr contents) = return $ Char contents+exprToVal (StringExpr contents) = return $ String contents+exprToVal (NumberExpr contents) = return $ Number contents+exprToVal (FloatExpr contents) = return $ Float contents+exprToVal (InductiveDataExpr cons argExprs) = do+ args <- mapM exprToVal argExprs+ return $ InductiveData cons args+exprToVal (CollectionExpr innerExprs) = do+ innerVals <- mapM innerExprToInnerVal innerExprs+ return $ Collection innerVals+exprToVal (TupleExpr innerExprs) = do+ innerVals <- mapM innerExprToInnerVal innerExprs+ return $ Tuple innerVals+exprToVal _ = throwError $ Default "read: invalid value"++innerExprToInnerVal :: InnerExpr -> ThrowsError InnerVal+innerExprToInnerVal (ElementExpr expr) = exprToVal expr >>= return . Element+innerExprToInnerVal (SubCollectionExpr expr) = exprToVal expr >>= return . SubCollection
+ hs-src/Language/Egison/Types.hs view
@@ -0,0 +1,421 @@+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 Data.Maybe+import System.IO+import Text.ParserCombinators.Parsec hiding (spaces)++--+-- Error+--+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++--+-- Expression+--+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)])]++--+-- Value+--+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++data InnerValRef = IElement ObjectRef+ | ISubCollection ObjectRef++type DestructInfo = [(String, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]++--+-- Internal Data+--+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]+ }++--+-- Type Class+--+-- |Convert a list of Egison objects into a space-separated string+unwordsList :: Show a => [a] -> String+unwordsList = unwords . map show++-- |Convert a list of Egison objects into a '_'-separated string+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 ++ ")"+ +-- |Allow conversion of egisonexpr instances to strings+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 -- Is this OK?++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"++-- |Allow conversion of egisonval instances to strings+instance Show EgisonVal where show = showVal++--showInnerVals :: [InnerVal] -> String+--showInnerVals [] = ""+--showInnerVals ((Element val):rest) = show val ++ showInnerVals' rest+--showInnerVals ((SubCollection val):rest) = "@" ++ show val ++ showInnerVals' rest++--showInnerVals' :: [InnerVal] -> String+--showInnerVals' [] = ""+--showInnerVals' ((Element val):rest) = " " ++ show val ++ showInnerVals' rest+--showInnerVals' ((SubCollection val):rest) = " @" ++ show val ++ showInnerVals' rest++showInnerVals :: [InnerVal] -> String+showInnerVals iVals = unwordsList $ innerValsToList iVals++showIVal :: IntermidiateVal -> String+showIVal (IInductiveData cons []) = "<" ++ cons ++ ">"+showIVal (IInductiveData cons _) = "<" ++ cons ++ " " ++ "..." ++ ">"+showIVal (ITuple _) = "[" ++ "..." ++ "]"+showIVal (ICollection _) = "{" ++ "..." ++ "}"++-- |Allow conversion of egisonfixedval instances to strings+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>"++-- |Allow conversion of egison object instances to strings+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++-- - utility+stringToCharCollection :: String -> IO EgisonVal+stringToCharCollection = undefined
+ hs-src/Language/Egison/Variables.hs view
@@ -0,0 +1,126 @@+module Language.Egison.Variables where+import Language.Egison.Types+import Control.Monad.Error+import Data.IORef+import qualified Data.Map++-- |Show the contents of an environment+printEnv :: Env -- ^Environment+ -> IO String -- ^Contents of the env as a string+printEnv env = do+ bindings <- liftIO $ readIORef $ topFrameRef env+ l <- mapM showBind $ Data.Map.toList bindings + return $ unlines l+ where + showBind ((name, nums), objRef) = do+ obj <- liftIO $ readIORef objRef+ return $ name ++ unwordsNums nums ++ ": " ++ show obj++-- |Create a copy of an environment+copyEnv :: Env -- ^ Source environment+ -> IO Env -- ^ A copy of the source environment+copyEnv env = do+ bindings <- liftIO $ readIORef $ topFrameRef env+ bindingListT <- mapM addBinding $ Data.Map.toList bindings+ bindingList <- newIORef $ Data.Map.fromList bindingListT+ return $ Environment (parentEnv env) bindingList+ where addBinding (var, val) = do --ref <- newIORef $ liftIO $ readIORef val+ x <- liftIO $ readIORef val+ ref <- newIORef x+ return (var, ref)++-- |Extend given environment by binding a series of values to a new environment.+extendEnv :: Env -- ^ Environment+ -> [(Var, ObjectRef)] -- ^ Extensions to the environment+ -> IO Env -- ^ Extended environment+extendEnv env abindings = do bindinglist <- newIORef $ Data.Map.fromList abindings+ return $ Environment (Just env) bindinglist++makeLetRecFrame :: Env+ -> [(String, EgisonExpr)]+ -> IO FrameRef+makeLetRecFrame env abindings = do+ newEnv <- extendLetRec env abindings+ return $ topFrameRef newEnv+ +-- |Extend given environment by binding a series of values to a new environment for letrec.+extendLetRec :: Env -- ^ Environment + -> [(String, EgisonExpr)] -- ^ Extensions to the environment+ -> IO Env -- ^ Extended environment+extendLetRec env abindings = do+ bindinglistT <- (mapM addDummyBinding abindings) -- >>= newIORef+ bindinglist <- newIORef $ Data.Map.fromList $ map (\(name,objRef) -> ((name,[]),objRef)) bindinglistT+ let newEnv = Environment (Just env) bindinglist+ mapM (replaceWithNewEnv newEnv) bindinglistT+ return newEnv+ where addDummyBinding (name, expr) = do dummy <- nullEnv+ objRef <- makeClosure dummy expr+ return (name, objRef)+ replaceWithNewEnv newEnv (_, objRef) = do obj <- readIORef objRef+ case obj of+ Closure _ cExpr -> writeIORef objRef (Closure newEnv cExpr)++-- |Recursively search environments to find one that contains the given variable.+findEnv + :: Env -- ^Environment to begin the search; + -- parent env's will be searched as well.+ -> Var -- ^Variable+ -> IO (Maybe Env) -- ^Environment, or Nothing if there was no match.+findEnv envRef var = do+ found <- liftIO $ isBound envRef var+ if found+ then return (Just envRef)+ else case parentEnv envRef of+ (Just par) -> findEnv par var+ Nothing -> return Nothing++-- |Determine if a variable is bound+isBound + :: Env -- ^ Environment+ -> Var -- ^ Variable+ -> IO Bool -- ^ True if the variable is bound+isBound envRef var = + (readIORef $ topFrameRef envRef) >>= return . Data.Map.member var++-- |Determine if a variable is bound+-- or a parent of the given environment.+isRecBound + :: Env -- ^ Environment+ -> Var -- ^ Variable+ -> IO Bool -- ^ True if the variable is bound+isRecBound envRef var = do+ env <- findEnv envRef var+ case env of+ (Just e) -> isBound e var+ Nothing -> return False++getVarFromFrame :: Frame -> Var -> IOThrowsError ObjectRef+getVarFromFrame frame var = do+ case Data.Map.lookup var frame of+ (Just a) -> return a+ Nothing -> throwError $ UnboundVar "Getting an unbound variable" (showVar var)+ +-- |Retrieve the value of a variable defined+getVar :: Env -- ^ Environment+ -> Var -- ^ Variable+ -> IOThrowsError ObjectRef -- ^ Contents of the variable+getVar envRef+ var = do binds <- liftIO $ readIORef $ topFrameRef envRef+ case Data.Map.lookup var binds of+ (Just a) -> return a+ Nothing -> case parentEnv envRef of+ (Just par) -> getVar par var+ Nothing -> (throwError $ UnboundVar "Getting an unbound variable" (showVar var))++-- |Bind a variable+defineVar+ :: Env -- ^ Environment + -> Var -- ^ Variable+ -> ObjectRef -- ^ Value+ -> IOThrowsError () -- ^ Result+defineVar envRef+ var objRef = do+ liftIO $ do+ env <- readIORef $ topFrameRef envRef+ writeIORef (topFrameRef envRef) (Data.Map.insert var objRef env)+ return ()
+ lib/core/base.egi view
@@ -0,0 +1,70 @@+;;+;; Base.egi+;;++(define $Something (type {[$var-match (lambda [$tgt] {tgt})]}))++(define $Bool+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[true []+ {[<true> {[]}]+ [#t {[]}]+ [_ {}]}]+ [false []+ {[<false> {[]}]+ [#f {[]}]+ [_ {}]}]})]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Bool Bool]+ {[[<true> <true>] #t]+ [[<true> #t] #t]+ [[#t <true>] #t]+ [[<false> <false>] #t]+ [[<false> #f] #t]+ [[#f <false>] #t]+ [[_ _] <false>]}))]}))++(define $or+ (lambda [$b1 $b2]+ (match b1 Bool+ {[<true> #t]+ [<false> b2]})))++(define $and+ (lambda [$b1 $b2]+ (match b1 Bool+ {[<true> b2]+ [<false> #f]})))++(define $not+ (lambda [$b]+ (match b Bool+ {[<true> #f]+ [<false> #t]})))++(define $Order+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[less []+ {[<less> {[]}]+ [_ {}]}]+ [equal []+ {[<equal> {[]}]+ [_ {}]}]+ [greater []+ {[<greater> {[]}]+ [_ {}]}]})]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Order Order]+ {[[<less> <less>] #t]+ [[<equal> <equal>] #t]+ [[<greater> <greater>] #t]+ [[_ _] #f]}))]}))+
+ lib/core/collection.egi view
@@ -0,0 +1,207 @@+;;+;; Collection.egi+;;++(define $List+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[nil []+ {[{} {[]}]+ [_ {}]}]+ [cons [a (List a)]+ {[{$x .$xs} {[x xs]}]+ [_ {}]}]+ [snoc [a (List a)]+ {[{.$xs $x} {[x xs]}]+ [_ {}]}]+ [join [(List a) (List a)]+ {[$tgt (letrec {[$loop-fn+ (lambda [$ts]+ (match ts (List a)+ {[<nil> {[{} {}]}]+ [<cons $x $xs>+ {[{} ts]+ @(map (lambda [$as $bs] [{x @as} bs])+ (loop-fn xs))}]}))]}+ (loop-fn tgt))]}]+ [nioj [(List a) (List a)]+ {[$tgt (letrec {[$loop-fn+ (lambda [$ts]+ (match ts (List a)+ {[<nil> {[{} {}]}]+ [<snoc $x $xs>+ {[{} ts]+ @(map (lambda [$as $bs] [{@as x} bs])+ (loop-fn xs))}]}))]}+ (loop-fn tgt))]}]})]+ [$= (lambda [$val $tgt]+ (match [val tgt] [(List a) (List a)]+ {[[<nil> <nil>] #t]+ [[<cons $x $xs> <cons ,x ,xs>] #t]+ [[_ _] #f]}))]})))++(define $map+ (lambda [$fn $ls]+ (match ls (List Something)+ {[<nil> {}]+ [<cons $x $xs> {(fn x) @(map fn xs)}]})))++(define $filter+ (lambda [$pred $ls]+ (match ls (List Something)+ {[<nil> {}]+ [<cons $x $xs>+ (if (pred x)+ {x @(filter pred xs)}+ (filter pred xs))]})))++(define $remove+ (lambda [$a]+ (lambda [$xs $x]+ (match xs (List a)+ {[<nil> {}]+ [<cons ,x $rs> rs]+ [<cons $y $rs> {y @((remove a) rs x)}]}))))++(define $remove-all+ (lambda [$a]+ (lambda [$xs $x]+ (match xs (List a)+ {[<nil> {}]+ [<cons ,x $rs> ((remove-all a) rs x)]+ [<cons $y $rs> {y @((remove-all a) rs x)}]}))))++(define $remove-collection+ (lambda [$a]+ (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> xs]+ [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))++(define $add+ (lambda [$a]+ (lambda [$xs $x]+ (match ((member? Integer) x xs) Bool+ {[#t xs]+ [#f {@xs x}]}))))++(define $union+ (lambda [$a]+ (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> xs]+ [<cons $y $rs> ((union a) ((add a) xs y) rs)]}))))++(define $subcollections+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {{}}]+ [<cons $x $rs>+ (let {[$subs (subcollections rs)]}+ {@subs @(map (lambda [$sub] {x @sub})+ subs)})]})))++(define $size+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> 0]+ [<cons _ $rs> (+ 1 (size rs))]})))++(define $car+ (lambda [$xs]+ (match xs (List Something)+ {[<cons $x _> x]})))++(define $cdr+ (lambda [$xs]+ (match xs (List Something)+ {[<cons _ $ys> ys]})))++(define $reverse+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {}]+ [<cons $x $rs>+ {@(reverse rs) x}]})))++(define $member?+ (lambda [$a]+ (lambda [$x $ys]+ (match ys (List a)+ {[<nil> #f]+ [<cons ,x $ys> #t]+ [<cons $y $ys> ((member? a) x ys)]}))))++(define $unique+ (lambda [$a]+ (lambda [$xs]+ (letrec {[$loop-fn (lambda [$xs $ys]+ (match xs (List a)+ {[<nil> ys]+ [<cons $x $rs>+ (if ((member? a) x ys)+ (loop-fn rs ys)+ (loop-fn rs {@ys x}))]}))]}+ (loop-fn xs {})))))++(define $subcollection?+ (lambda [$a]+ (lambda [$xs $ys]+ (match xs (List a)+ {[<nil> #t]+ [<cons $x $rest>+ (if ((member? a) x ys)+ ((subcollection? a) rest ys)+ #f)]}))))+ ++(define $concat+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {}]+ [<cons $x $rs> {@x @(concat rs)}]})))++(define $Multiset+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[nil []+ {[{} {[]}]+ [_ {}]}]+ [cons [a (Multiset a)]+ {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])+ ((unique a) tgt))]}]+ [join [(Multiset a) (Multiset a)]+ {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])+ (subcollections tgt))]}]})]+ [$= (lambda [$val $tgt]+ (match [val tgt] [(Multiset a) (Multiset a)]+ {[[<nil> <nil>] #t]+ [[<cons $x $xs> <cons ,x ,xs>] #t]+ [[_ _] #f]}))]})))++(define $Set+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[nil []+ {[{} {[]}]+ [_ {}]}]+ [cons [a (Set a)]+ {[$tgt (let {[$tgt2 ((unique a) tgt)]}+ {@(match-all tgt2 (Multiset a) [<cons $x $xs> [x xs]])+ @(match-all tgt2 (Multiset a) [<cons $x $xs> [x {@xs x}]])})]}]+ [join [(Set a) (Set a)]+ {[$tgt (let {[$tgt2 ((unique a) tgt)]}+ (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}])+ (subcollections xs)))+ (match-all tgt2 (Multiset a) [<join $xs $ys> [xs ys]]))))]}]})]+ [$= (lambda [$val $tgt]+ (and ((subcollection? a) val tgt) ((subcollection? a) tgt val)))]})))
+ lib/core/number.egi view
@@ -0,0 +1,69 @@+(define $Integer+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$= (lambda [$val $tgt] (eq? val tgt))]}))++(define $compare-integer+ (lambda [$m $n]+ (if (lt? m n)+ <less>+ (if (eq? m n)+ <equal>+ <greater>))))++(define $Double+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$= (lambda [$val $tgt] (eq-f? val tgt))]}))++(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[o []+ {[0 {[]}]+ [_ {}]}]+ [s [Nat]+ {[$tgt (match (compare-integer tgt 0) Order+ {[<greater> {(- tgt 1)}]+ [_ {}]})]}]})]+ [$= (lambda [$val $tgt] (eq? val tgt))]}))++(define $between+ (lambda [$m $n]+ (match (compare-integer m n) Order+ {[<less> {m @(between (+ m 1) n)}]+ [<equal> {n}]+ [<greater> {}]})))++(define $min+ (lambda [$ns]+ (match ns (List Integer)+ {[<cons $n <nil>> n]+ [<cons $n $rs>+ (let {[$r (min rs)]}+ (match (compare-integer n r) Order+ {[<less> n]+ [_ r]}))]})))++(define $max+ (lambda [$ns]+ (match ns (List Integer)+ {[<cons $n <nil>> n]+ [<cons $n $rs>+ (let {[$r (max rs)]}+ (match (compare-integer n r) Order+ {[<greater> n]+ [_ r]}))]})))++(define $gcd+ (lambda [$ns]+ (match ns (Set Integer)+ {[<cons $n <nil>> n]+ [<cons (& ,(min ns) $m)+ $rs>+ (gcd {m @((remove-all Integer)+ (map (lambda [$r] (mod r m))+ rs)+ 0)})]})))
+ lib/graph.egi view
@@ -0,0 +1,40 @@+(define $Node Integer)++(define $NodeInfo+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[node [Node (Multiset Node) (Multiset Node)]+ {[<node $n $in $out> {[n in out]}]}]})]+ [$= (lambda [$val $tgt]+ (match [val tgt] [NodeInfo NodeInfo]+ {[[<node $n $in $out> <node ,n ,in ,out>] #t]+ [[_ _] #f]}))]}))++(define $Graph (Multiset NodeInfo))++(define $hamilton-cycle+ (lambda [$g]+ (let {[$n (size g)]}+ (match-all g Graph+ [<cons <node $a_1 <cons $a_2 _> _>+ (loop $l $i (between 3 n)+ <cons <node ,a_(- i 1) <cons $a_i _> _>+ l>+ <cons <node ,a_n <cons ,a_1 _> _>+ _>)>+ [@(loop $l $i (between 1 n) {a_i @l} {})]]))))++(define $hamilton-path+ (lambda [$g]+ (let {[$n (size g)]}+ (match-all g Graph+ [<cons <node $a_1 <cons $a_2 _> _>+ (loop $l $i (between 3 n)+ <cons <node ,a_(- i 1) <cons $a_i _> _>+ l>+ <cons <node ,a_n _ _>+ <nil>>)>+ [@(loop $l $i (between 1 n) {a_i @l} {})]]))))+
+ lib/poker-hands.egi view
@@ -0,0 +1,110 @@+(define $Suit+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[spade []+ {[<spade> {[]}]+ [_ {}]}]+ [heart []+ {[<heart> {[]}]+ [_ {}]}]+ [club []+ {[<club> {[]}]+ [_ {}]}]+ [diamond []+ {[<diamond> {[]}]+ [_ {}]}]})]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Suit Suit]+ {[[<spade> <spade>] #t]+ [[<heart> <heart>] #t]+ [[<club> <club>] #t]+ [[<diamond> <diamond>] #t]+ [[_ _] #f]}))]}))++(define $Mod+ (lambda [$m]+ (type+ {[$var-match (lambda [$tgt] {(mod tgt m)})]+ [$= (lambda [$val $tgt] (eq? (mod val m) (mod tgt m)))]})))++(define $Card+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[card [Suit (Mod 13)]+ {[<card $s $n> {[s n]}]}]})]+ [$= (lambda [$val $tgt]+ (match [val tgt] [Card Card]+ {[[<card $s $n> <card ,s ,n>] #t]+ [[_ _] #f]}))]}))++(define $poker-hands+ (lambda [$Cs]+ (match Cs (Multiset Card)+ {[<cons <card $S $n>+ <cons <card ,S ,(- n 1)>+ <cons <card ,S ,(- n 2)>+ <cons <card ,S ,(- n 3)>+ <cons <card ,S ,(- n 4)>+ !<nil>>>>>>+ <straight-flush>]+ [<cons <card _ $n>+ <cons <card _ ,n>+ !<cons <card _ ,n>+ !<cons <card _ ,n>+ !<cons _+ !<nil>>>>>>+ <four-of-kind>]+ [<cons <card _ $m>+ <cons <card _ ,m>+ <cons <card _ ,m>+ <cons <card _ $n>+ !<cons <card _ ,n>+ !<nil>>>>>>+ <full-house>]+ [<cons <card $S _>+ !<cons <card ,S _>+ !<cons <card ,S _>+ !<cons <card ,S _>+ !<cons <card ,S _>+ !<nil>>>>>>+ <flush>]+ [<cons <card _ $n>+ <cons <card _ ,(- n 1)>+ <cons <card _ ,(- n 2)>+ <cons <card _ ,(- n 3)>+ <cons <card _ ,(- n 4)>+ !<nil>>>>>>+ <straight>]+ [<cons <card _ $n>+ <cons <card _ ,n>+ <cons <card _ ,n>+ <cons _+ <cons _+ !<nil>>>>>>+ <three-of-kind>]+ [<cons <card _ $m>+ <cons <card _ ,m>+ !<cons <card _ $n>+ <cons <card _ ,n>+ !<cons _+ !<nil>>>>>>+ <two-pair>]+ [<cons <card _ $n>+ <cons <card _ ,n>+ <cons _+ <cons _+ <cons _+ !<nil>>>>>>+ <one-pair>]+ [<cons _+ <cons _+ <cons _+ <cons _+ <cons _+ !<nil>>>>>>+ <nothing>]})))
+ sample/collection-test.egi view
@@ -0,0 +1,184 @@+(test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer))+ [<cons <cons $x _>+ <cons <cons $y _>+ <cons <cons $z _>+ <nil>>>>+ [x y z]]))++(test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Integer))+ [<cons <cons $n _>+ <cons <cons ,n _>+ <cons <cons ,n _>+ <nil>>>>+ n]))++(test (match-all {1 2 3 4 5} (Multiset Integer)+ [<cons $m <cons $n _>> [m n]]))++(test (let {[$pat <cons ,1 <nil>>]}+ (match {1} (Multiset Integer)+ {[pat <ok>]+ [_ <not-ok>]})))++(test (match {1} (Multiset Integer)+ {[(| <nil> <cons ,1 <nil>>) <ok>]+ [_ <not-ok>]}))++(test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))++(test (match-all {1 2 3} (List Integer)+ [<join $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (List Integer)+ [<nioj $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (Multiset Integer)+ [<join $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (Set Integer)+ [<join $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (List Integer)+ [<join $hs <cons $x $ts>> [hs x ts]]))++(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))++(test (subcollections {<x> <y> <z>}))++(test (poker-hands {<card <club> 4>+ <card <club> 2>+ <card <club> 5>+ <card <club> 1>+ <card <club> 3>}))++(test (poker-hands {<card <diamond> 1>+ <card <club> 2>+ <card <club> 1>+ <card <heart> 1>+ <card <diamond> 2>}))++(test (poker-hands {<card <diamond> 4>+ <card <club> 2>+ <card <club> 5>+ <card <heart> 1>+ <card <diamond> 3>}))++(test (poker-hands {<card <diamond> 4>+ <card <club> 10>+ <card <club> 5>+ <card <heart> 1>+ <card <diamond> 3>}))++(test (match {2 7 7 2 7} (Multiset Integer)+ {[<cons $m+ <cons ,m+ <cons ,m+ <cons $n+ !<cons ,n+ !<nil>>>>>>+ <ok>]+ [_ <ko>]}))++(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer)+ [<cons $x+ <cons $y+ <cons $z+ <nil>>>>+ [x y z]]))++(test (match-all {0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9} (Multiset Integer)+ [<cons $x+ <cons $y+ <cons $z+ !<nil>>>>+ [x y z]]))++(test (match {5 2 1 3 4} (Multiset Integer)+ {[<cons $n+ <cons ,(- n 1)+ <cons ,(- n 2)+ <cons ,(- n 3)+ <cons ,(- n 4)+ <nil>>>>>>+ <ok>]+ [_ <ko>]}))++(test (let {[$f (lambda [$x] (+ (g x) 10))]+ [$g (lambda [$x] (+ x 1))]}+ (f 0)))+++(define $Stick+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[nil []+ {[$tgt (match-all tgt (List a) [<nil> []])]}]+ [cons [a (List a)]+ {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])+ @(match-all (reverse tgt) (List a) [<cons $x $xs> [x xs]])}]}]+ [join [(List a) (List a)]+ {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])+ @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]}]})]+ [$equal? (lambda [$val $tgt]+ (or ((type-ref (List a) equal?) val tgt)+ ((type-ref (List a) equal?) val (reverse tgt))))]})))++(test (match-all {1 2 3} (Stick Integer) [<cons $x $xs> [x xs]]))+(test (match-all {1 2 3} (Stick Integer) [<join $xs $ys> [xs ys]]))+(test (match-all {1 2 3 4} (Stick Integer) [<join $xs <cons $w $ys>> [xs w ys]]))+(test (match-all {1 2 3} (Stick Integer) [,{3 2 1} <ok>]))++(test (match-all {1 2 3 4 5} (List Integer)+ [<join _ <cons $m <join _ <cons $n _>>>> [m n]]))++(test (match-all {1 2 3 4} (List Integer)+ [<join _ <join $ns _>> ns]))++(define $combination+ (lambda [$xs $k]+ (match k Nat+ {[<o> {{}}]+ [<s $k1>+ (concat (match-all xs (List Something)+ [<join _ <cons $x $rs>>+ (map (lambda [$ys]+ {x @ys})+ (combination rs k1))]))]})))++(test (combination {1 2 3 4 5} 3))++<join _ <cons $n_1 ... <join _ <cons $n_k _>> ... >>++(... [$n Integer (squence 1 k (lambda [$i] (+ i 1)))]+ <join _ <cons $n_i ...>> _)++(define $loop-pat+ (lambda [$k $i]+ (match i Integer+ {[,k <join _ <cons $n_k _>>]+ [_ <join _ <cons $n_i (loop-pat k (+ i 1))>>]})))++(define $loop-pat+ (lambda [$k]+ (| <nil> <cons ,k (loop-pat (- k 1))>)))++(define $isStraight?+ (lambda [$Ns]+ (match Ns (Multiset Integer)+ {[<cons $n+ (loop-pat (- n 1))>+ <ok>]+ [_ <ko>]})))++(define $isStraight?+ (lambda [$Ns]+ (match Ns (Multiset Integer)+ {[<cons (as $n (max Ns))+ (loop-pat (- n 1))>+ <ok>]+ [_ <ko>]})))++(test (isStraight? {1 2}))
+ sample/graph-test.egi view
@@ -0,0 +1,34 @@+(define $g {<node 1 {2 3 4 5} {2 3 4 5}>+ <node 2 {1 3} {1 3}>+ <node 3 {1 2 4} {1 2 4}>+ <node 4 {1 3 5} {1 3 5}>+ <node 5 {1 5} {1 5}>})++(test (match-all g Graph+ [<cons <node $n1 <cons $n2 _> _>+ <cons <node ,n2 <cons $n3 _> _>+ <cons <node ,n3 <cons ,n1 _> _>+ _>>>+ [n1 n2 n3]]))++(test (match-all g Graph+ [<cons <node $n1 <cons $n2 _> _>+ <cons <node ,n2 <cons $n3 _> _>+ <cons <node ,n3 <cons $n4 _> _>+ <cons <node ,n4 <cons $n5 _> _>+ <cons <node ,n5 <cons ,n1 _> _>+ _>>>>>+ [n1 n2 n3 n4 n5]]))++(test (match-all g Graph+ [<cons <node $n1 <cons $n2 _> _>+ <cons <node ,n2 <cons $n3 _> _>+ <cons <node ,n3 <cons $n4 _> _>+ <cons <node ,n4 <cons $n5 _> _>+ <cons <node ,n5 _ _>+ <nil>>>>>>+ [n1 n2 n3 n4 n5]]))++(test (hamilton-cycle g))++(test (hamilton-path g))
+ sample/io-test.egi view
@@ -0,0 +1,76 @@+(define $main+ (lambda [$: $argv]+ (do {[$: (write : {1 2 3})]+ [$: (write-char : '\n')]}+ :)))++(define $main+ (lambda [$: $argv]+ (do {[$: (print : "Hello world!")]}+ :)))++(define $main+ (lambda [$: $argv]+ (do {[[$: $p] (open-output-file : "hello.txt")]+ [$: (print-to-port : p "Hello world!")]}+ :)))++(define $main+ (lambda [$: $argv]+ (do {[$: (write-string : "input char : ")]+ [$: (flush :)]+ [[$: $c] (read-char :)]+ [$: (write-string : "output : ")]+ [$: (write-char : c)]+ [$: (write-char : '\n')]}+ :)))++(define $main+ (lambda [$: $argv]+ (do {[$: (write-string : "input : ")]+ [$: (flush :)]+ [[$: $str] (read-line :)]+ [$: (write-string : "output : ")]+ [$: (print : str)]}+ :)))++(define $main+ (lambda [$: $argv]+ (do {[$: (write-string : "input : ")]+ [$: (flush :)]+ [[$: $val] (read :)]+ [$: (write-string : "output : ")]+ [$: (write : val)]+ [$: (write-char : '\n')]}+ :)))++(define $main+ (lambda [$: $argv]+ (do {[$: (write-string : "input number : ")]+ [$: (flush :)]+ [[$: $num] (read :)]+ [$: (write-string : "output : ")]+ [$: (write : (+ num 1))]+ [$: (write-char : '\n')]}+ :)))++(define $main+ (lambda [$:]+ (do {[$: (print : "Return world? (y/n) : ")]+ [[$: $c] (read-char :)]}+ (match c Character+ {['y' :]+ ['n' 0]}))))++(execute)+++(define $main+ (lambda [$:]+ (do {[$: (print : "Return world? (1/0) : ")]+ [[$: $n] (read :)]}+ (match n Integer+ {[,1 :]+ [,0 0]}))))++(execute)
+ sample/number-test.egi view
@@ -0,0 +1,38 @@+(define $fib+ (lambda [$n]+ (match n Nat+ {[<o> 1]+ [<s <o>> 1]+ [<s <s $n1>> (+ (fib (+ n1 1)) (fib n1))]})))++(test (fib 10))++(define $fact+ (lambda [$n]+ (match n Nat+ {[<o> 1]+ [<s $n1> (* n (fact n1))]})))++(test (fact 10))++(define $min+ (lambda [$ns]+ (match ns (List Integer)+ {[<cons $n <nil>> n]+ [<cons $n $rs>+ (let {[$r (min rs)]}+ (match (compare-integer n r) Order+ {[<less> n]+ [_ r]}))]})))++(define $gcd+ (lambda [$ns]+ (let {[$ns2 ((remove-all Integer) ns 0)]}+ (match ns2 (Set Integer)+ {[<cons $n <nil>> n]+ [<cons ,(min ns2)+ $rs>+ (gcd {(min ns2) @(map (lambda [$r] (mod r (min ns2)))+ rs)})]}))))++(test (gcd {10 20 40 35}))
+ sample/poker-hands-test.egi view
@@ -0,0 +1,23 @@+(test (poker-hands {<card <club> 4>+ <card <club> 2>+ <card <club> 13>+ <card <club> 1>+ <card <club> 3>}))++(test (poker-hands {<card <diamond> 1>+ <card <club> 2>+ <card <club> 1>+ <card <heart> 1>+ <card <diamond> 2>}))++(test (poker-hands {<card <diamond> 4>+ <card <club> 2>+ <card <club> 5>+ <card <heart> 1>+ <card <diamond> 3>}))++(test (poker-hands {<card <diamond> 4>+ <card <club> 10>+ <card <club> 5>+ <card <heart> 1>+ <card <diamond> 3>}))