egison 0.1.1 → 0.1.2
raw patch · 5 files changed
+364/−307 lines, 5 filesdep +parsec3dep −parsec
Dependencies added: parsec3
Dependencies removed: parsec
Files
- Egison.hs +217/−98
- egison.cabal +5/−3
- etc/elisp/egison-mode.el +1/−0
- etc/sample/list-test.egi +130/−186
- etc/sample/nat-test.egi +11/−20
Egison.hs view
@@ -10,7 +10,7 @@ main :: IO () main = do args <- getArgs case length args of- 0 -> do flushStr "Egison, version 0.1.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+ 0 -> do flushStr "Egison, version 0.1.2 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" defsRef <- newIORef [] runRepl defsRef _ -> putStrLn "Program takes only 0 argument!"@@ -21,8 +21,8 @@ runRepl defs = do input <- (readPrompt "> ") case input of Eof -> flushStr "\nLeaving Egison.\nByebye. See you again! (^^)/\n"- Input str -> runIOThrows ((liftThrows (readTopExpression str)) >>= executeTopExpression defs) >>= putStrLn >> runRepl defs--- Input str -> runIOThrows (liftThrows (liftM show (readTopExpression str))) >>= putStrLn >> runRepl defs+ Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defs) >>= flushStr >> runRepl defs+-- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs readPrompt :: String -> IO Input readPrompt prompt = flushStr prompt >> getExpression@@ -38,7 +38,6 @@ return (Input str)) (\_ -> return Eof) - getExpressionHelper :: Bool -> Integer -> IO String getExpressionHelper b n = do c <- getChar case c of@@ -75,15 +74,17 @@ type IOThrowsError = ErrorT EgiError IO data EgiError = Parser ParseError- | NotFunction String | UnboundVariable String+ | WithTopExpression String Expression+ | WithExpression String Expression | Default String showError :: EgiError -> String-showError (Parser parseErr) = "Parse error at " ++ show parseErr-showError (NotFunction str) = "Error : " ++ str-showError (UnboundVariable name) = "Error : unbound variable" ++ name-showError (Default str) = "Error : " ++ str+showError (Parser parseErr) = "Parse error at " ++ show parseErr ++ "\n"+showError (UnboundVariable name) = "Error : unbound variable : " ++ name ++ "\n"+showError (WithTopExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"+showError (WithExpression str expr) = "Error : " ++ str ++ " :\n" ++ show expr ++ "\n"+showError (Default str) = "Error : " ++ str ++ "\n" instance Show EgiError where show = showError @@ -91,6 +92,8 @@ 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@@ -98,38 +101,45 @@ runIOThrows :: IOThrowsError String -> IO String runIOThrows action = runErrorT (trapError action) >>= return . extractValue -readTopExpression :: String -> ThrowsError TopExpression-readTopExpression = readOrThrow parseTopExpression+trapError :: (MonadError e m, Show e) => m String -> m String+trapError action = catchError action (return . show) -readTopExpressionList :: String -> ThrowsError [TopExpression]-readTopExpressionList = readOrThrow (endBy parseTopExpression spaces)+extractValue :: ThrowsError a -> a+extractValue (Right val) = val++readTopExpression :: String -> IOThrowsError TopExpression+readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr)++--readTopExpressionList :: String -> IOThrowsError [TopExpression]+--readTopExpressionList = liftThrows (readOrThrow (sepBy parseTopExpression spaces)) readOrThrow :: Parser a -> String -> ThrowsError a readOrThrow parser input = case parse parser "egison" input of Left err -> throwError (Parser err) Right val -> return val -type ThrowsError = Either EgiError--trapError :: (MonadError e m, Show e) => m String -> m String-trapError action = catchError action (return . show)--extractValue :: ThrowsError a -> a-extractValue (Right val) = val- executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String executeTopExpression defs (Define name expr) = do liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))- return name+ return (name ++ "\n") executeTopExpression defs (Test expr) = do topFrame <- makeTopFrame defs val <- eval (Environment [topFrame]) expr- liftIO (showValue val)+ ret <- liftIO (showValue val)+ return (ret ++ "\n") executeTopExpression defs Execute = do topFrame <- makeTopFrame defs- val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp []))- liftIO (showValue val)+ mainFn <- eval (Environment [topFrame]) (SymbolExp "main")+ args <- liftIO (newIORef (Value (World [])))+ case mainFn of+ Function funEnv fpat body+ -> do frame <- makeFrame fpat args+ iValRef <- liftIO (makeClosure (addFrame frame funEnv) body)+ forceRecursively iValRef+ return ""+ _ -> throwError (Default "main is not function" ) + -- -- Data Types --@@ -148,8 +158,9 @@ | CollectionExp [InnerExp] | PatternExp PatternExp | FunctionExp FunPat Expression- | LetExp Bind Expression- | TypeExp Bind+ | DoExp Bind Expression+ | LetExp RecursiveBind Expression+ | TypeExp RecursiveBind | TypeRefExp Expression String | DeconstructorExp DeconsInfoExp | MatchExp Expression Expression [MatchClause]@@ -170,13 +181,18 @@ data FunPat = FunPatVar String | FunPatTuple [FunPat] -type Bind = [(String, Expression)]+type Bind = [(FunPat, Expression)] +type RecursiveBind = [(String, Expression)]+ type DeconsInfoExp = [(String, Expression, [(PrimePat, Expression)])] data MatchClause = MatchClause Expression Expression data PrimePat = PrimeWildCard+ | PrimePatCharacter Char+ | PrimePatInteger Integer+ | PrimePatDouble Double | PrimePatVar String | InductivePrimePat String [PrimePat] | EmptyPat@@ -300,15 +316,21 @@ spaces body <- parseExpression return (FunctionExp args body)- <|> do try (do string "let"+ <|> do try (do string "do" spaces1) bind <- parseBind spaces body <- parseExpression+ return (DoExp bind body)+ <|> do try (do string "let"+ spaces1)+ bind <- parseRecursiveBind+ spaces+ body <- parseExpression return (LetExp bind body) <|> do try (do string "type" spaces1)- bind <- parseBind+ bind <- parseRecursiveBind return (TypeExp bind) <|> do try (do string "type-ref" spaces1)@@ -365,13 +387,21 @@ _ -> return (FunPatTuple fpats)) parseBind :: Parser Bind-parseBind = braces (do bs <- sepEndBy (brackets (do char '$'- var <- word+parseBind = braces (do bs <- sepEndBy (brackets (do fpat <- parseFunPat spaces expr <- parseExpression- return (var, expr)))+ return (fpat, expr))) spaces return bs)+ +parseRecursiveBind :: Parser RecursiveBind+parseRecursiveBind = braces (do bs <- sepEndBy (brackets (do char '$'+ var <- word+ spaces+ expr <- parseExpression+ return (var, expr)))+ spaces+ return bs) parseDeconsInfoExp :: Parser DeconsInfoExp parseDeconsInfoExp = braces (sepEndBy parseDeconsClause spaces)@@ -393,6 +423,12 @@ 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)@@ -536,7 +572,7 @@ appendFrames :: Frame -> Frame -> Frame appendFrames (Frame frame1) (Frame frame2) = Frame (frame1 ++ frame2) -makeRecursiveFrame :: Environment -> Bind -> IOThrowsError Frame+makeRecursiveFrame :: Environment -> RecursiveBind -> IOThrowsError Frame makeRecursiveFrame env bind = let vars = map fst bind in let exprs = map snd bind in@@ -566,46 +602,71 @@ -- readValue :: String -> IOThrowsError Value-readValue = undefined---readValue = readOrThrow parseValue+readValue exprStr = do+ expr <- readExpression exprStr+ expressionToValue expr ---getValue :: IO String---getValue = getExpressionHelper False 0+readExpression :: String -> IOThrowsError Expression+readExpression exprStr = liftThrows (readOrThrow parseExpression exprStr) -parseValue :: Parser Value-parseValue = do c <- charLiteral- return (Character c)--- <|> do str <- stringLiteral--- return (String str)- <|> do d <- try float- return (Double d)- <|> do n <- try integer- return (Integer n)--- <|> angles (do c <- word--- spaces--- vs <- sepEndBy parseValue spaces--- return (InductiveData c vs))--- <|> brackets (do vs <- sepEndBy parseValue spaces--- return (Tuple vs))--- <|> braces (do vs <- sepEndBy parseInnerValue spaces--- return (Collection vs))--- <|> try (do pat <- parsePatternValue--- return (Pattern pat))+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+ iValRefs <- liftIO (valListToIValRefList vals)+ return (InductiveData con iValRefs)+expressionToValue (TupleExp exprs) = do+ vals <- expressionToValueMap exprs+ case vals of+ [val] -> return val+ _ -> do iValRefs <- liftIO (valListToIValRefList vals)+ return (Tuple iValRefs)+expressionToValue (CollectionExp innerExps) = do+ innerVals <- innerExpToInnerValueMap innerExps+ return (Collection innerVals)+expressionToValue expr@(PatternExp _) = throwError (WithExpression "not implemented yet :" expr)+expressionToValue expr = throwError (WithExpression "read expression is not value :" 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+ iValRef <- liftIO (newIORef (Value val))+ innerVals <- innerExpToInnerValueMap rest+ return (Element iValRef:innerVals)+innerExpToInnerValueMap (SubCollectionExp expr:rest) = do+ val <- expressionToValue expr+ iValRef <- liftIO (newIORef (Value val))+ innerVals <- innerExpToInnerValueMap rest+ return (SubCollection iValRef:innerVals)+ showValue :: Value -> IO 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 iValRefs) = do- vals <- iValListToValueList iValRefs+ vals <- iValRefListToValueList iValRefs str <- unwordsVals vals return ("<" ++ cons ++ " " ++ str ++ ">") showValue (Tuple []) = do return ("[]") showValue (Tuple iValRefs) = do- vals <- iValListToValueList iValRefs+ vals <- iValRefListToValueList iValRefs str <- unwordsVals vals return ("[" ++ str ++ "]") showValue (Collection []) = do@@ -622,6 +683,8 @@ return "#<type>" showValue (DeconstructorFunction _) = do return "#<deconstructor-function>"+showValue (Deconstructor _ _) = do+ return "#<deconstructor>" showValue (BuiltinFunction _) = do return "#<builtin-function>" @@ -692,22 +755,27 @@ return (Collection innerVals) eval1 env (PatternExp patExp) = evalPattern1 env patExp eval1 env (FunctionExp args body) = return (Function env args body)-eval1 (Environment frames) (LetExp bind body) = do- frame <- makeRecursiveFrame (Environment frames) bind- iValRef <- liftIO (newIORef (Closure (Environment (frame:frames)) body))+eval1 env (DoExp [] body) = eval1 env body+eval1 env (DoExp ((fpat,expr):assocs) body) = do+ iValRef <- liftIO (makeClosure env expr)+ frame <- makeFrame fpat iValRef+ eval1 (addFrame frame env) (DoExp assocs body)+eval1 env (LetExp bind body) = do+ frame <- makeRecursiveFrame env bind+ iValRef <- liftIO (newIORef (Closure (addFrame frame env) body)) force iValRef eval1 env (TypeExp bind) = do frame <- makeRecursiveFrame env bind return (Type frame)-eval1 env (TypeRefExp typExp name) = do+eval1 env expr@(TypeRefExp typExp name) = do typVal <- eval1 env typExp case typVal of (Type frame) -> let mIValRef = getValueFromFrame frame name in case mIValRef of- Nothing -> throwError (Default ("no method in type : " ++ name))+ Nothing -> throwError (WithExpression ("no method in type : " ++ name) expr) Just iValRef -> do val <- force iValRef return val- _ -> throwError (Default "first arg of typeref is not type")+ _ -> throwError (WithExpression "first arg of typeref is not type :" expr) eval1 env (DeconstructorExp deconsInfoExp) = do deconsInfo <- liftIO (makeDeconsInfo env deconsInfoExp) return (DeconstructorFunction deconsInfo)@@ -719,18 +787,18 @@ typIVal <- liftIO (makeClosure env typExp) tgtIVal <- liftIO (makeClosure env tgtExp) forceMatchMapExp env typIVal tgtIVal mC -eval1 env (ApplyExp fnExp argsExp) = do+eval1 env expr@(ApplyExp fnExp argsExp) = do fnVal <- eval1 env fnExp argsIValRef <- liftIO (makeClosure env argsExp) case fnVal of BuiltinFunction builtinFn -> do argsVal <- forceRecursively argsIValRef argsVals <- liftIO (tupleToValueList argsVal) builtinFn argsVals- Function (Environment funEnv) fpat body -> do frame <- makeFrame fpat argsIValRef- iValRef <- liftIO (makeClosure (Environment (frame:funEnv)) body)- force iValRef+ Function funEnv fpat body -> do frame <- makeFrame fpat argsIValRef+ iValRef <- liftIO (makeClosure (addFrame frame funEnv) body)+ force iValRef DeconstructorFunction deconsInfo -> return (Deconstructor argsIValRef deconsInfo)- _ -> throwError (NotFunction "Applying non-functional object.") + _ -> throwError (WithExpression "applying non-functional object :" expr) evalPattern1 :: Environment -> PatternExp -> IOThrowsError Value evalPattern1 _ WildCardExp = return (Pattern WildCard)@@ -825,7 +893,7 @@ [] -> forceMatchExp env typIValRef tgtIValRef rest (frame:_) -> do iValRef <- liftIO (makeClosure (addFrame frame env) expr) force iValRef-forceMatchExp _ _ _ _ = throwError (Default "end of match clause") +forceMatchExp _ _ _ _ = throwError (Default "end of match clause") forceMatchMapExp :: Environment -> (IORef IntermidiateValue) -> (IORef IntermidiateValue) -> MatchClause -> IOThrowsError Value forceMatchMapExp env typIValRef tgtIValRef (MatchClause pat expr) = do@@ -896,8 +964,8 @@ newFrames2 <- patternMatch frames typVal (Pattern (OnPat vars onEnv expr)) tgtIValRef return (newFrames1 ++ newFrames2) patternMatch frames (Type bind) (Pattern (ValPat iValPatRef)) tgtIValRef = do- case getValueFromFrame bind "=" of- Nothing -> throwError (Default "no = function")+ case getValueFromFrame bind "equal?" of+ Nothing -> throwError (Default "no equal? function") Just valMatchFnRef -> do valMatchFn <- force valMatchFnRef case valMatchFn of Function funEnv fpat body -> do argsIValRef <- liftIO (newIORef (Value (Tuple [iValPatRef, tgtIValRef])))@@ -907,9 +975,9 @@ case val of (InductiveData "true" []) -> return frames (InductiveData "false" []) -> return []- _ -> throwError (Default "invalid return value from = function")- _ -> throwError (Default "= is not function")-patternMatch _ _ _ _ = throwError (Default "invalid pattern")+ _ -> throwError (Default "invalid return value from equal? function")+ _ -> throwError (Default "equal? is not function")+patternMatch _ _ _ _ = throwError (Default "invalid pattern : you shold add ',' to the head of value pattern") doDeconstruct :: DeconsInfo -> [Frame] -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame] doDeconstruct [] _ _ _ = throwError (Default "no match decons clause")@@ -957,6 +1025,27 @@ primitivePatternMatch :: PrimePat -> IORef IntermidiateValue -> IOThrowsError (Maybe Frame) primitivePatternMatch PrimeWildCard _ = return (Just (Frame []))+primitivePatternMatch (PrimePatCharacter c) iValRef = do+ val <- force iValRef+ case val of+ Character c2 -> if c == c2+ then return (Just (Frame []))+ else return Nothing+ _ -> throwError (Default "primitive : not character to primitive character pat")+primitivePatternMatch (PrimePatInteger n) iValRef = do+ val <- force iValRef+ case val of+ Integer n2 -> if n == n2+ then return (Just (Frame []))+ else return Nothing+ _ -> throwError (Default "primitive : not integer to primitive integer pat")+--primitivePatternMatch (PrimePatDouble d) iValRef = do+-- val <- force iValRef+-- 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) iValRef = return (Just (Frame [(name, iValRef)])) primitivePatternMatch (InductivePrimePat pCons pPats) iValRef = do val <- force iValRef@@ -1008,7 +1097,7 @@ case mRestFrame of Nothing -> return Nothing Just restFrame -> return (Just (appendFrames frame restFrame))-primitivePatternMatchMap _ _ = throwError (Default "primitivePatternMatchMap : number of patterns and targets are different") +primitivePatternMatchMap _ _ = throwError (Default "primitivePatternMatchMap : number of patterns and targets are different") isEmptyCollection :: Value -> IOThrowsError Bool isEmptyCollection (Collection []) = return True@@ -1035,8 +1124,8 @@ case cdrVal of Collection cdrRefs -> do restRef <- liftIO (newIORef (Value (Collection (cdrRefs ++ rest)))) return (carRef, restRef)-consDeconstruct (Collection []) = throwError (Default "empty collection") -consDeconstruct _ = throwError (Default "consDeconstruct : not collection") +consDeconstruct (Collection []) = throwError (Default "empty collection")+consDeconstruct _ = throwError (Default "consDeconstruct : not collection") snocDeconstruct :: Value -> IOThrowsError (IORef IntermidiateValue, IORef IntermidiateValue) snocDeconstruct (Collection innerVals) =@@ -1053,18 +1142,25 @@ case rdcVal of Collection rdcRefs -> do restRef <- liftIO (newIORef (Value (Collection ((reverse rest) ++ rdcRefs)))) return (racRef, restRef)-snocDeconstruct _ = throwError (Default "snocDeconstruct : not collection") +snocDeconstruct _ = throwError (Default "snocDeconstruct : not collection") --- --- --- -iValListToValueList :: [IORef IntermidiateValue] -> IO [Value]-iValListToValueList [] = return []-iValListToValueList (iValRef:iValRefs) = do+valListToIValRefList :: [Value] -> IO [IORef IntermidiateValue]+valListToIValRefList [] = return []+valListToIValRefList (val:vals) = do+ iValRef <- newIORef (Value val)+ iValRefs <- valListToIValRefList vals+ return (iValRef:iValRefs)++iValRefListToValueList :: [IORef IntermidiateValue] -> IO [Value]+iValRefListToValueList [] = return []+iValRefListToValueList (iValRef:iValRefs) = do iVal <- readIORef iValRef case iVal of- Value val -> do vals <- iValListToValueList iValRefs+ Value val -> do vals <- iValRefListToValueList iValRefs return (val:vals) tupleToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue]@@ -1143,18 +1239,21 @@ "write" -> Just builtinWrite "read-char" -> Just builtinReadChar "write-char" -> Just builtinWriteChar+ "=" -> Just builtinEqual "+" -> Just builtinPlus "-" -> Just builtinMinus "*" -> Just builtinMultiply+ "/" -> Just builtinDevide+ "mod" -> Just builtinMod _ -> Nothing builtinRead :: [Value] -> IOThrowsError Value---builtinRead [(World actions)] = do--- str <- getExpression--- val <- readValue str--- ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])--- return ret-builtinRead _ = throwError (Default "invalid args to read") +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@@ -1165,7 +1264,9 @@ builtinReadChar :: [Value] -> IOThrowsError Value builtinReadChar [(World actions)] = do- undefined+ 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@@ -1174,6 +1275,15 @@ return (World ((Write (Character c)):actions)) builtinWriteChar _ = throwError (Default "invalid args to write-char") +builtinEqual :: [Value] -> IOThrowsError Value+builtinEqual [(Integer n1), (Integer n2)] = if (n1 == n2)+ then return (InductiveData "true" [])+ else return (InductiveData "false" [])+builtinEqual [(Double n1), (Double n2)] = if (n1 == n2)+ then return (InductiveData "true" [])+ else return (InductiveData "false" [])+builtinEqual _ = throwError (Default "invalid args to =")+ builtinPlus :: [Value] -> IOThrowsError Value builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2)) builtinPlus [(Double n1), (Double n2)] = return (Double (n1 + n2))@@ -1189,6 +1299,15 @@ builtinMultiply [(Double n1), (Double n2)] = return (Double (n1 * n2)) builtinMultiply _ = throwError (Default "invalid args to *") +builtinDevide :: [Value] -> IOThrowsError Value+builtinDevide [(Integer n1), (Integer n2)] = return (Integer (div n1 n2))+builtinDevide [(Double n1), (Double n2)] = return (Double (n1 / n2))+builtinDevide _ = throwError (Default "invalid args to /")++builtinMod :: [Value] -> IOThrowsError Value+builtinMod [(Integer n1), (Integer n2)] = return (Integer (mod n1 n2))+builtinMod _ = throwError (Default "invalid args to mod")+ --- --- for Debug : show Expression ---@@ -1210,8 +1329,8 @@ showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}" showExpression (PatternExp pat) = show pat showExpression (FunctionExp args expr) = "(lambda " ++ show args ++ " " ++ show expr ++ ")"-showExpression (LetExp bind expr) = "(let " ++ showBind bind ++ " " ++ show expr ++ ")"-showExpression (TypeExp bind) = "(type " ++ showBind bind ++ ")"+showExpression (LetExp bind expr) = "(let " ++ showRecursiveBind bind ++ " " ++ show expr ++ ")"+showExpression (TypeExp bind) = "(type " ++ showRecursiveBind bind ++ ")" showExpression (TypeRefExp typ name) = "(type-ref " ++ show typ ++ " " ++ name ++ ")" showExpression (DeconstructorExp deconsInfoExp) = "(deconstructor " ++ showDeconsInfoExp deconsInfoExp ++ ")" showExpression (MatchExp tgt typ clss) = "(match " ++ show tgt ++ " " ++ show typ ++ " {" ++ unwordsList clss ++ "})"@@ -1237,12 +1356,12 @@ instance Show PatternExp where show = showPatternExp -showBind :: Bind -> String-showBind [] = "{}"-showBind bind = "{" ++ unwords (map showBindHelper bind) ++ "}"+showRecursiveBind :: RecursiveBind -> String+showRecursiveBind [] = "{}"+showRecursiveBind bind = "{" ++ unwords (map showRecursiveBindHelper bind) ++ "}" -showBindHelper :: (String, Expression) -> String-showBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]"+showRecursiveBindHelper :: (String, Expression) -> String+showRecursiveBindHelper (name, expr) = "[$" ++ name ++ " " ++ show expr ++ "]" showFunPat :: FunPat -> String showFunPat (FunPatVar name) = "$" ++ name
egison.cabal view
@@ -7,14 +7,16 @@ -- 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: 0.1.1+Version: 0.1.2 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison -- A longer description of the package. Description: An interpreter for the programming language Egison.- A eature of Egison is the strong pattern match facility.+ A feature of Egison is the strong pattern match facility.+ With Egison, you can represent pattern matching for non-inductive 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. @@ -58,7 +60,7 @@ Main-is: Egison.hs -- Packages needed in order to build this package.- Build-depends: base >= 4.0 && < 5, haskell98, mtl, parsec+ Build-depends: base >= 4.0 && < 5, haskell98, mtl, parsec3 -- Modules not exported by this package. -- Other-modules:
etc/elisp/egison-mode.el view
@@ -8,6 +8,7 @@ "\\<execute\\>" "\\<lambda\\>"+ "\\<do\\>" "\\<let\\>" "\\<type\\>" "\\<type-ref\\>"
etc/sample/list-test.egi view
@@ -1,3 +1,23 @@+(define $Bool+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[true []+ {[<true> {[]}]+ [_ {}]}]+ [false []+ {[<falset> {[]}]+ [_ {}]}]+ })]+ [$equal?+ (lambda [$val $tgt]+ (match [val tgt] [Suit Suit]+ {[[<true> <true>] <true>]+ [[<false> <false>] <true>]+ [[_ _] <false>]}))]+ }))+ (define $Something (type {[$var-match (lambda [$tgt] {tgt})]@@ -21,9 +41,9 @@ {[<diamond> {[]}] [_ {}]}] })]- [$=+ [$equal? (lambda [$val $tgt]- (match [val tgt] [Card Card]+ (match [val tgt] [Suit Suit] {[[<spade> <spade>] <true>] [[<heart> <heart>] <true>] [[<club> <club>] <true>]@@ -31,75 +51,49 @@ [[_ _] <false>]}))] })) -(test (match-map <club> Suit [<club> <ok>]))+(test ((type-ref Suit equal?) <spade> <spade>)) (define $Nat (type {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[o []- {[<o> {[]}]- [_ {}]- }]- [s [Nat]- {[<s $x> {x}]- [_ {}]- }]- })]- [$=- (lambda [$val $tgt]- (match [val tgt] [Nat Nat]- {[[<o> <o>] <true>]- [[<s $n1> <s $n2>] (= n1 n2)]- [[_ _] <false>]}))]- }))--(define $monus- (lambda [$m $n]- (match [m n] [Nat Nat]- {[[_ <o>] m]- [[<o> _] <o>]- [[<s $m1> <s $n1>] (monus m1 n1)]})))+ [$equal? (lambda [$val $tgt]+ (= val tgt))]})) -(test (monus <s <s <o>>> <s <o>>))+(define $Mod+ (lambda [$m]+ (type+ {[$var-match (lambda [$tgt] {(mod tgt m)})]+ [$equal? (lambda [$val $tgt]+ (= (mod val m) (mod tgt m)))]}))) -(define $mod- (lambda [$m $n]- (match (monus m n) Nat- {[<o> m]- [$m1 (mod m1 n)]})))+(test (match 10 Nat+ {[,(- 12 2) <ok>]+ [_ <not-ok>]})) -(test (mod <s <s <s <s <o>>>>> <s <s <s <o>>>>))+(test (match 10 (Mod 13)+ {[,(- 12 2) <ok>]+ [_ <not-ok>]})) -(define $Mod- (lambda [$m]- (let {[$Loop- (type {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[o []- {[<o> {[]}]- [_ {}]- }]- [s [Loop]- {[<s $x> {x}]- [<o> {m}]- }]})]- [$= (lambda [$val $tgt]- ((type-ref Nat =) (mod val m) tgt))]})]}- (type- {[$var-match (lambda [$tgt] {(mod tgt m)})]- [$inductive-match- (lambda [$tgt]- ((type-ref Loop inductive-match) (mod tgt m)))]- [$= (lambda [$val $tgt]- ((type-ref Nat =) (mod val m) (mod tgt m)))]}))))+(define $Card+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[card [Suit (Mod 13)]+ {[<card $s $n> {[s n]}]}]})]+ [$equal? (lambda [$val $tgt]+ (match [val tgt] [Card Card]+ {[[<card $s $n>+ <card (on [$s] ,s) (on [$n] ,n)>]+ <true>]+ [[_ _] <false>]}))]})) -(test (match <s <s <s <s <o>>>>> (Mod <s <s <s <o>>>>)- {[<o> <not-ok>]- [<s <o>> <ok>]- [<s <s <o>>> <not-ok>]}))+(test (match <card <diamond> 12> Card+ {[<card <club> ,12> <not-ok>]+ [<card <diamond> ,10> <not-ok>]+ [,<card <diamond> 12> <ok2>]+ [<card _ ,12> <ok>]+ [_ <not-ok>]})) (define $List (lambda [$a]@@ -144,7 +138,7 @@ (loop tgt))] }] })]- [$= (lambda [$val $tgt]+ [$equal? (lambda [$val $tgt] (match [val tgt] [(List a) (List a)] {[[<nil> <nil>] <true>] [[<cons $x $xs>@@ -153,11 +147,7 @@ [[_ _] <false>]}))] }))) -(test ((type-ref (List Nat) =) {<o> <s <o>>} {<o> <s <o>>}))--(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<snoc $x $xs> [x xs]]))--(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<nioj $xs $ys> [xs ys]]))+(test (match-map {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]])) (define $map (lambda [$fn $ls]@@ -165,14 +155,6 @@ {[<nil> {}] [<cons $x $xs> {(fn x) @(map fn xs)}]}))) -(test (map (lambda [$a] <s a>) {<o> <s <o>>}))--(test (match {} (List Something)- {[<join $hs $ts> [hs ts]]}))--(test (match-map {<x> <y>} (List Something)- [<join $hs $ts> [hs ts]]))- (test (match-map {<x> <y> <z> <w>} (List Something) [<join $hs <cons $x $ts>> [hs x ts]])) @@ -181,11 +163,13 @@ (lambda [$xs $x] (match xs (List a) {[<nil> {}]- [<cons x $rs> rs]+ [<cons ,x $rs> rs] [<cons $y $rs> {y @((remove a) rs x)}]})))) -(test ((remove Nat) {<o> <s <o>>} <o>))+(test ((remove Suit) {<club> <diamond>} <diamond>)) +(test ((remove Nat) {1 2} 1))+ (define $remove-collection (lambda [$a] (lambda [$xs $ys]@@ -193,7 +177,7 @@ {[<nil> xs] [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]})))) -(test ((remove-collection Nat) {<o> <s <o>> <s <s <o>>>} {<o> <s <s <o>>>}))+(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>})) (define $subcollection (lambda [$xs]@@ -205,7 +189,7 @@ subs)})] }))) -(test (subcollection {<o> <s <o>> <s <s <o>>>}))+(test (subcollection {<x> <y> <z>})) (define $Multiset (lambda [$a]@@ -213,66 +197,68 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (deconstructor- {[nil []- {[{} {[]}]- [_ {}]- }]- [cons [a (Multiset a)]- {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])- 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>] <true>]- [[<cons $x $xs>- <cons (on [$x] x) (on [$xs] xs)>]- <true>]- [[_ _] <false>]}))]+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (Multiset a)]+ {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])+ 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 (on [$x] ,x) (on [$xs] ,xs)>]+ <true>]+ [[_ _] <false>]}))] }))) + (define $one-pair (lambda [$ns]+ (match ns (Multiset Suit)+ {[<cons $n <cons (on [$n] ,n) _>> <ok>]+ [_ <nothing>]})))+ +(test (one-pair {<club> <spade> <club>}))++(define $list-nat+ (lambda [$ns]+ (match ns (List Nat)+ {[<cons $n <cons (on [$n] ,n) _>> n]+ [_ <not-ok>]})))++(test (list-nat {1 1 3}))++(define $multiset-nat+ (lambda [$ns] (match ns (Multiset Nat)- {[<cons $m- <cons (on [$m] m)- _>>- <ok>]- [_ <nothing>]- })))+ {[<cons $n <cons (on [$n] ,n) _>> n]+ [_ <not-ok>]}))) -(test (one-pair {<o> <s <o>> <o>}))+(test (multiset-nat {1 1 3})) (define $full-house (lambda [$ns] (match ns (Multiset Nat) {[<cons $m- <cons (on [$m] m)- <cons (on [$m] m)+ <cons (on [$m] ,m)+ <cons (on [$m] ,m) !<cons $n- !<cons (on [$n] n)+ !<cons (on [$n] ,n) !<nil> >>>>> <full-house>] [_ <nothing>] }))) -(test (full-house {<o> <o> <s <o>> <o> <s <o>>}))--(define $thirteen <s <s <s <s <s <s <s <s <s <s <s <s <s <o>>>>>>>>>>>>>>)--(define $Card- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[card [Suit (Mod thirteen)]- {[<card $s $n> {[s n]}]}]})]- [$= <undefined>]}))+(test (full-house {1 1 0 0 1})) (define $poker-hands (lambda [$Cs]@@ -350,71 +336,29 @@ >>>>> <nothing>]}))) -(define $poker-hands-without-strait- (lambda [$Cs]- (match Cs (Multiset Card)- {[<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <four-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- !<cons <card _ (on [$n] ,n)>- !<nil>- >>>>>- <full-house>]- [<cons <card $S _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<nil>- >>>>>- <flush>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<nil>- >>>>>- <three-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <two-pair>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <one-pair>]- [<cons _- !<cons _- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <nothing>]})))+(test (poker-hands {<card <club> 4>+ <card <club> 2>+ <card <club> 5>+ <card <club> 1>+ <card <club> 3>})) -(test (poker-hands-without-strait {<card <diamond> <o>>- <card <club> <s <o>>>- <card <club> <o>>- <card <heart> <o>>- <card <diamond> <s <o>>>}))+(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>})) (define $car (lambda [$as]
etc/sample/nat-test.egi view
@@ -12,7 +12,7 @@ [_ {}] }] })]- [$=+ [$equal? (lambda [$val $tgt] (match [val tgt] [Nat Nat] {[[<o> <o>] <true>]@@ -20,8 +20,6 @@ [[_ _] <false>]}))] })) -(test ((type-ref Nat =) <o> <o>))- (define $+ (lambda [$m $n] (match m Nat@@ -52,27 +50,20 @@ (test (fib <s <s <s <s <s <s <o>>>>>>>)) -(define $val-match-test- (lambda [$n]- (match n Nat- {[,(+ <s <o>> <s <s <o>>>) <ok>]- [$n1 n1]})))--(test (val-match-test <s <s <s <o>>>>))--(define $on-pat-test+(define $monus (lambda [$m $n] (match [m n] [Nat Nat]- {[[$m1 (on [$m1] <s m1>)] m1]- [[_ _] <not-ok>]})))+ {[[_ <o>] m]+ [[<o> _] <o>]+ [[<s $m1> <s $n1>] (monus m1 n1)]}))) -(test (on-pat-test <o> <s <o>>))+(test (monus <s <s <o>>> <s <o>>)) -(define $on-pat-test2+(define $mod (lambda [$m $n]- (match [m n] [Nat Nat]- {[[$m1 <s (on [$m1] m1)>] m1]- [[_ _] <not-ok>]})))+ (match (monus m n) Nat+ {[<o> m]+ [$m1 (mod m1 n)]}))) -(test (on-pat-test2 <o> <s <o>>))+(test (mod <s <s <s <s <o>>>>> <s <s <s <o>>>>))