diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -10,7 +10,7 @@ main :: IO () main = do args <- getArgs case length args of - 0 -> do flushStr "Egison, version 0.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" + 0 -> do flushStr "Egison, version 0.1.1 : 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!" @@ -24,19 +24,6 @@ Input str -> runIOThrows ((liftThrows (readTopExpression str)) >>= executeTopExpression defs) >>= putStrLn >> runRepl defs -- Input str -> runIOThrows (liftThrows (liftM show (readTopExpression str))) >>= putStrLn >> runRepl defs -executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String -executeTopExpression defs (Define name expr) = do - liftIO (modifyIORef defs (\ls -> ((name, expr) : ls))) - return name -executeTopExpression defs (Test expr) = do - topFrame <- makeTopFrame defs - val <- eval (Environment [topFrame]) expr - liftIO (showValue val) -executeTopExpression defs Execute = do - topFrame <- makeTopFrame defs - val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp [])) - liftIO (showValue val) - readPrompt :: String -> IO Input readPrompt prompt = flushStr prompt >> getExpression @@ -47,49 +34,55 @@ | Eof getExpression :: IO Input -getExpression = catch (do str <- (getExpressionHelper 0) +getExpression = catch (do str <- getExpressionHelper False 0 return (Input str)) (\_ -> return Eof) -getExpressionHelper :: Integer -> IO String -getExpressionHelper n = do c <- getChar - case c of - '(' -> do l <- getExpressionHelper (n + 1) - return (c : l) - '<' -> do l <- getExpressionHelper (n + 1) - return (c : l) - '[' -> do l <- getExpressionHelper (n + 1) - return (c : l) - '{' -> do l <- getExpressionHelper (n + 1) - return (c : l) - ')' -> do l <- getExpressionHelper (n - 1) - return (c : l) - '>' -> do l <- getExpressionHelper (n - 1) - return (c : l) - ']' -> do l <- getExpressionHelper (n - 1) - return (c : l) - '}' -> do l <- getExpressionHelper (n - 1) +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) - '\n' -> if n > 0 - then do l <- getExpressionHelper n - return (c : l) - else return "\n" - _ -> do l <- getExpressionHelper n - return (c : l) type IOThrowsError = ErrorT EgiError IO data EgiError = Parser ParseError | NotFunction String - | UnboundVariable String String + | UnboundVariable String | Default String showError :: EgiError -> String showError (Parser parseErr) = "Parse error at " ++ show parseErr showError (NotFunction str) = "Error : " ++ str -showError (UnboundVariable str name) = "Error : " ++ str ++ name +showError (UnboundVariable name) = "Error : unbound variable" ++ name showError (Default str) = "Error : " ++ str instance Show EgiError where show = showError @@ -124,6 +117,19 @@ 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 +executeTopExpression defs (Test expr) = do + topFrame <- makeTopFrame defs + val <- eval (Environment [topFrame]) expr + liftIO (showValue val) +executeTopExpression defs Execute = do + topFrame <- makeTopFrame defs + val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp [])) + liftIO (showValue val) + -- -- Data Types -- @@ -134,7 +140,7 @@ data Expression = CharacterExp Char | StringExp String - | NumberExp Integer + | IntegerExp Integer | DoubleExp Double | SymbolExp String | InductiveDataExp String [Expression] @@ -186,9 +192,9 @@ data IntermidiateValue = Closure Environment Expression | Value Value -data Value = World +data Value = World [Action] | Character Char - | Number Integer + | Integer Integer | Double Double | InductiveData String [IORef IntermidiateValue] | Tuple [IORef IntermidiateValue] @@ -200,6 +206,11 @@ | DeconstructorFunction DeconsInfo | BuiltinFunction ([Value] -> IOThrowsError Value) +data Action = Read Value + | Write Value + | Memorize Value + | Remember Value + data InnerValue = Element (IORef IntermidiateValue) | SubCollection (IORef IntermidiateValue) @@ -223,6 +234,10 @@ 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 ":+-*/=" @@ -238,32 +253,25 @@ spaces :: Parser () spaces = skipMany (oneOf " \n\t") +spaces1 :: Parser () +spaces1 = skipMany1 (oneOf " \n\t") + parseTopExpression :: Parser TopExpression -parseTopExpression = try (do char '(' - spaces - string "define" - spaces - char '$' - name <- word - spaces - expr <- parseExpression - spaces - char ')' - return (Define name expr)) - <|> try (do char '(' - spaces - string "test" - spaces - expr <- parseExpression - spaces - char ')' - return (Test expr)) - <|> try (do char '(' - spaces - string "execute" - spaces - char ')' - return Execute) +parseTopExpression = do spaces + parens (do try (string "define") + spaces + char '$' + name <- word + spaces + expr <- parseExpression + return (Define name expr) + <|> do try (string "test") + spaces + expr <- parseExpression + spaces + return (Test expr) + <|> do try (string "execute") + return Execute) "top expression" parseExpression :: Parser Expression parseExpression = do ws <- word @@ -272,119 +280,73 @@ return (CharacterExp c) <|> do str <- stringLiteral return (StringExp str) - <|> do n <- integer - return (NumberExp n) --- <|> try (do d <- float --- return (DoubleExp d)) - <|> do char '<' - spaces - c <- word - spaces - vs <- sepEndBy parseExpression spaces - char '>' - return (InductiveDataExp c vs) - <|> do char '[' - spaces - vs <- sepEndBy parseExpression spaces - char ']' - return (TupleExp vs) - <|> do char '{' - spaces - vs <- sepEndBy parseInnerExp spaces - char '}' - return (CollectionExp vs) + <|> do d <- try float + return (DoubleExp d) + <|> do n <- try integer + return (IntegerExp n) + <|> angles (do c <- word + spaces + vs <- sepEndBy parseExpression spaces + return (InductiveDataExp c vs)) + <|> brackets (do vs <- sepEndBy parseExpression spaces + return (TupleExp vs)) + <|> braces (do vs <- sepEndBy parseInnerExp spaces + return (CollectionExp vs)) <|> try (do pat <- parsePatternExp return (PatternExp pat)) - <|> try (do char '(' - spaces - string "lambda" - spaces - args <- parseFunPat - spaces - body <- parseExpression - spaces - char ')' - return (FunctionExp args body)) - <|> try (do char '(' - spaces - string "let" - spaces - bind <- parseBind - spaces - body <- parseExpression - spaces - char ')' - return (LetExp bind body)) - <|> try (do char '(' - spaces - string "type" - spaces - bind <- parseBind - spaces - char ')' - return (TypeExp bind)) - <|> try (do char '(' - spaces - string "type-ref" - spaces - typ <- parseExpression - spaces - name <- word - spaces - char ')' - return (TypeRefExp typ name)) - <|> try (do char '(' - spaces - string "deconstructor" - spaces - deconsInfo <- parseDeconsInfoExp - spaces - char ')' - return (DeconstructorExp deconsInfo)) - <|> try (do char '(' - spaces - string "match" - spaces - tgt <- parseExpression - spaces - typ <- parseExpression - spaces - char '{' - spaces - clss <- sepEndBy parseMatchClause spaces - char '}' - spaces - char ')' - return (MatchExp tgt typ clss)) - <|> try (do char '(' - spaces - string "match-map" - spaces - tgt <- parseExpression - spaces - typ <- parseExpression - spaces - cls <- parseMatchClause - spaces - char ')' - return (MatchMapExp tgt typ cls)) - <|> try (do char '(' - spaces - string "apply" - spaces - fn <- parseExpression - spaces - args <- parseExpression - spaces - char ')' - return (ApplyExp fn args)) - <|> do char '(' - spaces - fn <- parseExpression - spaces - args <- sepEndBy parseExpression spaces - char ')' - return (ApplyExp fn (TupleExp args)) + <|> parens (do try (do string "lambda" + spaces1) + args <- parseFunPat + spaces + body <- parseExpression + return (FunctionExp args body) + <|> do try (do string "let" + spaces1) + bind <- parseBind + spaces + body <- parseExpression + return (LetExp bind body) + <|> do try (do string "type" + spaces1) + bind <- parseBind + return (TypeExp bind) + <|> do try (do string "type-ref" + spaces1) + typ <- parseExpression + spaces + name <- word + return (TypeRefExp typ name) + <|> do try (do string "deconstructor" + spaces1) + deconsInfo <- parseDeconsInfoExp + return (DeconstructorExp 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-map" + spaces1) + tgt <- parseExpression + spaces + typ <- parseExpression + spaces + cls <- parseMatchClause + spaces + return (MatchMapExp tgt typ cls) + <|> do try (do string "apply" + spaces1) + fn <- parseExpression + spaces + args <- parseExpression + return (ApplyExp fn args) + <|> do fn <- parseExpression + spaces + args <- sepEndBy parseExpression spaces + return (ApplyExp fn (TupleExp args))) parseInnerExp :: Parser InnerExp parseInnerExp = do v <- parseExpression @@ -397,66 +359,36 @@ parseFunPat = do char '$' name <- word return (FunPatVar name) - <|> try (do char '[' - spaces - fpat <- parseFunPat - spaces - char ']' - return fpat) - <|> try (do char '[' - spaces - fpats <- sepEndBy parseFunPat spaces - char ']' - return (FunPatTuple fpats)) + <|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces)) + case fpats of + [fpat] -> return fpat + _ -> return (FunPatTuple fpats)) parseBind :: Parser Bind -parseBind = do char '{' - spaces - bs <- sepEndBy (do char '[' - spaces - char '$' - var <- word - spaces - expr <- parseExpression - spaces - char ']' - return (var, expr)) - spaces - char '}' - return bs +parseBind = braces (do bs <- sepEndBy (brackets (do char '$' + var <- word + spaces + expr <- parseExpression + return (var, expr))) + spaces + return bs) parseDeconsInfoExp :: Parser DeconsInfoExp -parseDeconsInfoExp = do char '{' - spaces - deconsInfoExp <- sepEndBy parseDeconsClause spaces - spaces - char '}' - return deconsInfoExp +parseDeconsInfoExp = braces (sepEndBy parseDeconsClause spaces) parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)]) -parseDeconsClause = do char '[' - spaces - patCons <- word - spaces - typExpr <- parseExpression - spaces - char '{' - spaces - dc2s <- sepEndBy parseDeconsClause2 spaces - char '}' - spaces - char ']' - return (patCons, typExpr, dc2s) +parseDeconsClause = brackets (do patCons <- word + spaces + typExpr <- parseExpression + spaces + dc2s <- braces (sepEndBy parseDeconsClause2 spaces) + return (patCons, typExpr, dc2s)) parseDeconsClause2 :: Parser (PrimePat, Expression) -parseDeconsClause2 = do char '[' - spaces - datPat <- parsePrimePat - spaces - expr <- parseExpression - spaces - char ']' - return (datPat, expr) +parseDeconsClause2 = brackets (do datPat <- parsePrimePat + spaces + expr <- parseExpression + return (datPat, expr)) parsePrimePat :: Parser PrimePat parsePrimePat = do char '_' @@ -464,13 +396,10 @@ <|> do char '$' name <- word return (PrimePatVar name) - <|> do char '<' - spaces - c <- word - spaces - ps <- sepEndBy parsePrimePat spaces - char '>' - return (InductivePrimePat c ps) + <|> angles (do c <- word + spaces + ps <- sepEndBy parsePrimePat spaces + return (InductivePrimePat c ps)) <|> try (do char '{' spaces char '}' @@ -481,7 +410,6 @@ spaces char '.' b <- parsePrimePat - spaces char '}' return (ConsPat a b)) <|> try (do char '{' @@ -490,19 +418,14 @@ a <- parsePrimePat spaces b <- parsePrimePat - spaces char '}' return (SnocPat a b)) parseMatchClause :: Parser MatchClause -parseMatchClause = do char '[' - spaces - pat <- parseExpression - spaces - body <- parseExpression - spaces - char ']' - return (MatchClause pat body) +parseMatchClause = brackets (do pat <- parseExpression + spaces + body <- parseExpression + return (MatchClause pat body)) parsePatternExp :: Parser PatternExp parsePatternExp = do char '_' @@ -516,49 +439,26 @@ <|> do char ',' expr <- parseExpression return (ValPatExp expr) - <|> try (do char '(' - spaces - string "as" - spaces - char '$' - name <- word - spaces - expr <- parseExpression - spaces - char ')' - return (AsPatExp name expr)) - <|> try (do char '(' - spaces - string "of" - spaces - expr <- parseExpression - spaces - char '}' - return (OfPatExp expr)) - <|> try (do char '(' - spaces - string "on" - spaces - var <- (char '$' >> word) - spaces - expr <- parseExpression - spaces - char ')' - return (OnPatExp [var] expr)) - <|> try (do char '(' - spaces - string "on" - spaces - char '[' - spaces - vars <- sepEndBy (char '$' >> word) spaces - char ']' - spaces - expr <- parseExpression - spaces - char ')' - return (OnPatExp vars expr)) - + <|> parens (do try (do string "as" + spaces1) + char '$' + name <- word + spaces + expr <- parseExpression + return (AsPatExp name expr) + <|> do try (do string "of" + spaces1) + expr <- parseExpression + return (OfPatExp expr) + <|> do try (do string "on" + spaces1) + vars <- try (do var <- (char '$' >> word) + return [var] + <|> brackets (sepEndBy (char '$' >> word) spaces)) + spaces + expr <- parseExpression + return (OnPatExp vars expr)) + -- -- Environment -- @@ -569,13 +469,13 @@ then Just iValRef else getValueFromFrame (Frame rest) name -getValue :: Environment -> String -> IOThrowsError (IORef IntermidiateValue) -getValue (Environment []) name = throwError (UnboundVariable "Unbound Variable : " name) +getValue :: Environment -> String -> Maybe (IORef IntermidiateValue) +getValue (Environment []) name = Nothing getValue (Environment (frame : env)) name = let mValRef = getValueFromFrame frame name in case mValRef of Nothing -> getValue (Environment env) name - Just iValRef -> return iValRef + Just iValRef -> Just iValRef makeClosure :: Environment -> Expression -> IO (IORef IntermidiateValue) makeClosure env expr = newIORef (Closure env expr) @@ -662,12 +562,39 @@ addFrame frame (Environment frames) = Environment (frame:frames) -- --- +-- read and show Value -- +readValue :: String -> IOThrowsError Value +readValue = undefined +--readValue = readOrThrow parseValue + +--getValue :: IO String +--getValue = getExpressionHelper False 0 + +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)) + showValue :: Value -> IO String showValue (Character c) = return (show c) -showValue (Number n) = return (show n) +showValue (Integer n) = return (show n) showValue (Double d) = return (show d) showValue (InductiveData cons []) = do return ("<" ++ cons ++ ">") @@ -701,7 +628,11 @@ showPattern :: Pattern -> IO String showPattern WildCard = return "_" showPattern (PatVar name) = return ("$" ++ name) -showPattern _ = undefined +showPattern (CutPat _) = return "#" +showPattern (AsPat _ _) = return "#" +showPattern (OfPat _) = return "#" +showPattern (OnPat _ _ _) = return "#" +showPattern (ValPat _) = return "#" unwordsList :: Show a => [a] -> String unwordsList = unwords . map show @@ -738,15 +669,16 @@ eval1 _ (StringExp str) = do val <- liftIO (makeCollectionFromValueList (map Character str)) return val -eval1 _ (NumberExp n) = return (Number n) +eval1 _ (IntegerExp n) = return (Integer n) eval1 _ (DoubleExp d) = return (Double d) -eval1 env (SymbolExp name) = do - let mBuiltinFn = getBuiltin name in - case mBuiltinFn of - Just builtinFn -> return (BuiltinFunction builtinFn) - Nothing -> do iValRef <- getValue env name - val <- force iValRef - return val +eval1 env (SymbolExp name) = + let mIValRef = getValue env name in + case mIValRef of + Just iValRef -> force iValRef + Nothing -> let mBuiltinFn = getBuiltin name in + case mBuiltinFn of + Just builtinFn -> return (BuiltinFunction builtinFn) + Nothing -> throwError (UnboundVariable name) eval1 env (InductiveDataExp con exprs) = do iValRefs <- liftIO (makeClosureList env exprs) return (InductiveData con iValRefs) @@ -1150,7 +1082,19 @@ Value val -> do vals <- tupleToValueList (Tuple iValRefs) return (val:vals) tupleToValueList val = return [val] - + +makeTupleFromValueList :: [Value] -> IO Value +makeTupleFromValueList vals = do + iValRefs <- makeIValRefList vals + return (Tuple iValRefs) + +makeIValRefList :: [Value] -> IO [IORef IntermidiateValue] +makeIValRefList [] = return [] +makeIValRefList (val:vals) = do + iValRef <- newIORef (Value val) + iValRefs <- makeIValRefList vals + return (iValRef:iValRefs) + collectionToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue] collectionToList iValRef = do val <- force iValRef @@ -1195,21 +1139,54 @@ getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value) getBuiltin name = case name of + "read" -> Just builtinRead + "write" -> Just builtinWrite + "read-char" -> Just builtinReadChar + "write-char" -> Just builtinWriteChar "+" -> Just builtinPlus "-" -> Just builtinMinus "*" -> Just builtinMultiply _ -> 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") +builtinWrite :: [Value] -> IOThrowsError Value +builtinWrite [(World actions), val] = do + valStr <- liftIO (showValue val) + liftIO (flushStr valStr) + return (World ((Write val):actions)) +builtinWrite _ = throwError (Default "invalid args to write") + +builtinReadChar :: [Value] -> IOThrowsError Value +builtinReadChar [(World actions)] = do + undefined +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") + builtinPlus :: [Value] -> IOThrowsError Value -builtinPlus [(Number n1), (Number n2)] = return (Number (n1 + n2)) +builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2)) +builtinPlus [(Double n1), (Double n2)] = return (Double (n1 + n2)) builtinPlus _ = throwError (Default "invalid args to +") builtinMinus :: [Value] -> IOThrowsError Value -builtinMinus [(Number n1), (Number n2)] = return (Number (n1 - n2)) +builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2)) +builtinMinus [(Double n1), (Double n2)] = return (Double (n1 - n2)) builtinMinus _ = throwError (Default "invalid args to -") builtinMultiply :: [Value] -> IOThrowsError Value -builtinMultiply [(Number n1), (Number n2)] = return (Number (n1 * n2)) +builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2)) +builtinMultiply [(Double n1), (Double n2)] = return (Double (n1 * n2)) builtinMultiply _ = throwError (Default "invalid args to *") --- @@ -1225,7 +1202,7 @@ showExpression :: Expression -> String showExpression (CharacterExp c) = show c -showExpression (NumberExp n) = show n +showExpression (IntegerExp n) = show n showExpression (SymbolExp name) = name showExpression (InductiveDataExp s []) = "<" ++ s ++ ">" showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">" diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -7,16 +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 +Version: 0.1.1 -- A short (one-line) description of the package. -Synopsis: Programming Language Egison +Synopsis: An Interpreter for the Programming Language Egison -- A longer description of the package. -Description: Feature of this programming language is the strong - pattern match facility. This package include sample Egison programming - codes "*-test.egi" in "sample/" directory. You can download ELisp file - "egison-mode.el" from the home page of Egison. +Description: An interpreter for the programming language Egison. + A eature of Egison is the strong pattern match facility. + 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/ @@ -41,16 +41,16 @@ Build-type: Simple -Data-Dir: sample +Data-Dir: etc/ -Data-files: nat-test.egi list-test.egi +Data-files: sample/nat-test.egi sample/list-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.4 +Cabal-version: >=1.6 Executable egison @@ -65,4 +65,7 @@ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - + +Source-Repository head + type: git + location: https://github.com/egisatoshi/egison diff --git a/etc/elisp/egison-mode.el b/etc/elisp/egison-mode.el new file mode 100644 --- /dev/null +++ b/etc/elisp/egison-mode.el @@ -0,0 +1,153 @@ +;;; egison-mode.el --- Egison editing mode + +(defconst egison-font-lock-keywords-1 + (eval-when-compile + (list + "\\" + "\\" + "\\" + + "\\" + "\\" + "\\" + "\\" + "\\" + "\\" + "\\" + + "\\\." + "\\\," + "\\\!" + "@" + "\\<_\\>" + "\\" + "\\" + "\\" + )) + "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) + ))) + "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) + (setq pc (+ pc 1)) + (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 "let" name) 2) + ((equal "match" name) 2) + ((equal "match-map" name) 2) + ((equal "type" name) 2) + ((equal "deconstructor" 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) diff --git a/etc/sample/list-test.egi b/etc/sample/list-test.egi new file mode 100644 --- /dev/null +++ b/etc/sample/list-test.egi @@ -0,0 +1,429 @@ +(define $Something + (type + {[$var-match (lambda [$tgt] {tgt})] + })) + +(define $Suit + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[spade [] + {[ {[]}] + [_ {}]}] + [heart [] + {[ {[]}] + [_ {}]}] + [club [] + {[ {[]}] + [_ {}]}] + [diamond [] + {[ {[]}] + [_ {}]}] + })] + [$= + (lambda [$val $tgt] + (match [val tgt] [Card Card] + {[[ ] ] + [[ ] ] + [[ ] ] + [[ ] ] + [[_ _] ]}))] + })) + +(test (match-map Suit [ ])) + +(define $Nat + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[o [] + {[ {[]}] + [_ {}] + }] + [s [Nat] + {[ {x}] + [_ {}] + }] + })] + [$= + (lambda [$val $tgt] + (match [val tgt] [Nat Nat] + {[[ ] ] + [[ ] (= n1 n2)] + [[_ _] ]}))] + })) + +(define $monus + (lambda [$m $n] + (match [m n] [Nat Nat] + {[[_ ] m] + [[ _] ] + [[ ] (monus m1 n1)]}))) + +(test (monus >> >)) + +(define $mod + (lambda [$m $n] + (match (monus m n) Nat + {[ m] + [$m1 (mod m1 n)]}))) + +(test (mod >>>> >>>)) + +(define $Mod + (lambda [$m] + (let {[$Loop + (type {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[o [] + {[ {[]}] + [_ {}] + }] + [s [Loop] + {[ {x}] + [ {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)))]})))) + +(test (match >>>> (Mod >>>) + {[ ] + [> ] + [>> ]})) + +(define $List + (lambda [$a] + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[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 + (lambda [$ts] + (match ts (List a) + {[ {[{} {}]}] + [ + {[{} ts] + @(map (lambda [$as $bs] + [{x @as} bs]) + (loop xs))}]}))]} + (loop tgt))] + }] + [nioj [(List a) (List a)] + {[$tgt (let {[$loop + (lambda [$ts] + (match ts (List a) + {[ {[{} {}]}] + [ + {[{} ts] + @(map (lambda [$as $bs] + [{@as x} bs]) + (loop xs))}]}))]} + (loop tgt))] + }] + })] + [$= (lambda [$val $tgt] + (match [val tgt] [(List a) (List a)] + {[[ ] ] + [[ + ] + ] + [[_ _] ]}))] + }))) + +(test ((type-ref (List Nat) =) { >} { >})) + +(test (match-map { > >>} (List Nat) [ [x xs]])) + +(test (match-map { > >>} (List Nat) [ [xs ys]])) + +(define $map + (lambda [$fn $ls] + (match ls (List Something) + {[ {}] + [ {(fn x) @(map fn xs)}]}))) + +(test (map (lambda [$a] ) { >})) + +(test (match {} (List Something) + {[ [hs ts]]})) + +(test (match-map { } (List Something) + [ [hs ts]])) + +(test (match-map { } (List Something) + [> [hs x ts]])) + +(define $remove + (lambda [$a] + (lambda [$xs $x] + (match xs (List a) + {[ {}] + [ rs] + [ {y @((remove a) rs x)}]})))) + +(test ((remove Nat) { >} )) + +(define $remove-collection + (lambda [$a] + (lambda [$xs $ys] + (match ys (List a) + {[ xs] + [ ((remove-collection a) ((remove a) xs y) rs)]})))) + +(test ((remove-collection Nat) { > >>} { >>})) + +(define $subcollection + (lambda [$xs] + (match xs (List Something) + {[ {{}}] + [ + (let {[$subs (subcollection rs)]} + {@subs @(map (lambda [$sub] {x @sub}) + subs)})] + }))) + +(test (subcollection { > >>})) + +(define $Multiset + (lambda [$a] + (type + {[$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)] + {[[ ] ] + [[ + ] + ] + [[_ _] ]}))] + }))) + +(define $one-pair + (lambda [$ns] + (match ns (Multiset Nat) + {[> + ] + [_ ] + }))) + +(test (one-pair { > })) + +(define $full-house + (lambda [$ns] + (match ns (Multiset Nat) + {[ + >>>>> + ] + [_ ] + }))) + +(test (full-house { > >})) + +(define $thirteen >>>>>>>>>>>>>) + +(define $Card + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[card [Suit (Mod thirteen)] + {[ {[s n]}]}]})] + [$= ]})) + +(define $poker-hands + (lambda [$Cs] + (match Cs (Multiset Card) + {[ + + + + + ! + >>>>> + ] + [ + + ! + ! + ! + >>>>> + ] + [ + + + ! + ! + ! + >>>>> + ] + [ + ! + ! + ! + ! + ! + >>>>> + ] + [ + + + + + ! + >>>>> + ] + [ + + + ! + >>>>> + ] + [ + + ! + + ! + >>>>> + ] + [ + + ! + >>>>> + ] + [ + >>>>> + ]}))) + +(define $poker-hands-without-strait + (lambda [$Cs] + (match Cs (Multiset Card) + {[ + + ! + ! + ! + >>>>> + ] + [ + + + ! + ! + ! + >>>>> + ] + [ + ! + ! + ! + ! + ! + >>>>> + ] + [ + + + ! + >>>>> + ] + [ + + ! + + ! + >>>>> + ] + [ + + ! + >>>>> + ] + [ + >>>>> + ]}))) + +(test (poker-hands-without-strait { > + >> + > + > + >>})) + +(define $car + (lambda [$as] + (match as (List Something) + {[ a]}))) + +(define $reverse + (lambda [$as] + (match as (List Something) + {[ {}] + [ + {@(reverse rs) a}]}))) diff --git a/etc/sample/nat-test.egi b/etc/sample/nat-test.egi new file mode 100644 --- /dev/null +++ b/etc/sample/nat-test.egi @@ -0,0 +1,78 @@ +(define $Nat + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (deconstructor + {[o [] + {[ {[]}] + [_ {}] + }] + [s [Nat] + {[ {x}] + [_ {}] + }] + })] + [$= + (lambda [$val $tgt] + (match [val tgt] [Nat Nat] + {[[ ] ] + [[ ] (= n1 n2)] + [[_ _] ]}))] + })) + +(test ((type-ref Nat =) )) + +(define $+ + (lambda [$m $n] + (match m Nat + {[ n] + [ ]}))) + +(define $* + (lambda [$m $n] + (match m Nat + {[ ] + [> n] + [ (+ n (* m1 n))]}))) + +(define $fact + (lambda [$n] + (match n Nat + {[ >] + [ (* n (fact n1))]}))) + +(test (fact >>>)) + +(define $fib + (lambda [$n] + (match n Nat + {[ >] + [> >] + [> (+ (fib ) (fib n1))]}))) + +(test (fib >>>>>>)) + +(define $val-match-test + (lambda [$n] + (match n Nat + {[,(+ > >>) ] + [$n1 n1]}))) + +(test (val-match-test >>>)) + +(define $on-pat-test + (lambda [$m $n] + (match [m n] [Nat Nat] + {[[$m1 (on [$m1] )] m1] + [[_ _] ]}))) + +(test (on-pat-test >)) + +(define $on-pat-test2 + (lambda [$m $n] + (match [m n] [Nat Nat] + {[[$m1 ] m1] + [[_ _] ]}))) + +(test (on-pat-test2 >)) + diff --git a/sample/list-test.egi b/sample/list-test.egi deleted file mode 100644 --- a/sample/list-test.egi +++ /dev/null @@ -1,429 +0,0 @@ -(define $Something - (type - {[$var-match (lambda [$tgt] {tgt})] - })) - -(define $Suit - (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[spade [] - {[ {[]}] - [_ {}]}] - [heart [] - {[ {[]}] - [_ {}]}] - [club [] - {[ {[]}] - [_ {}]}] - [diamond [] - {[ {[]}] - [_ {}]}] - })] - [$= - (lambda [$val $tgt] - (match [val tgt] [Card Card] - {[[ ] ] - [[ ] ] - [[ ] ] - [[ ] ] - [[_ _] ]}))] - })) - -(test (match-map Suit [ ])) - -(define $Nat - (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[o [] - {[ {[]}] - [_ {}] - }] - [s [Nat] - {[ {x}] - [_ {}] - }] - })] - [$= - (lambda [$val $tgt] - (match [val tgt] [Nat Nat] - {[[ ] ] - [[ ] (= n1 n2)] - [[_ _] ]}))] - })) - -(define $monus - (lambda [$m $n] - (match [m n] [Nat Nat] - {[[_ ] m] - [[ _] ] - [[ ] (monus m1 n1)]}))) - -(test (monus >> >)) - -(define $mod - (lambda [$m $n] - (match (monus m n) Nat - {[ m] - [$m1 (mod m1 n)]}))) - -(test (mod >>>> >>>)) - -(define $Mod - (lambda [$m] - (let {[$Loop - (type {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[o [] - {[ {[]}] - [_ {}] - }] - [s [Loop] - {[ {x}] - [ {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)))]})))) - -(test (match >>>> (Mod >>>) - {[ ] - [> ] - [>> ]})) - -(define $List - (lambda [$a] - (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[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 - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] - [{x @as} bs]) - (loop xs))}]}))]} - (loop tgt))] - }] - [nioj [(List a) (List a)] - {[$tgt (let {[$loop - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] - [{@as x} bs]) - (loop xs))}]}))]} - (loop tgt))] - }] - })] - [$= (lambda [$val $tgt] - (match [val tgt] [(List a) (List a)] - {[[ ] ] - [[ - ] - ] - [[_ _] ]}))] - }))) - -(test ((type-ref (List Nat) =) { >} { >})) - -(test (match-map { > >>} (List Nat) [ [x xs]])) - -(test (match-map { > >>} (List Nat) [ [xs ys]])) - -(define $map - (lambda [$fn $ls] - (match ls (List Something) - {[ {}] - [ {(fn x) @(map fn xs)}]}))) - -(test (map (lambda [$a] ) { >})) - -(test (match {} (List Something) - {[ [hs ts]]})) - -(test (match-map { } (List Something) - [ [hs ts]])) - -(test (match-map { } (List Something) - [> [hs x ts]])) - -(define $remove - (lambda [$a] - (lambda [$xs $x] - (match xs (List a) - {[ {}] - [ rs] - [ {y @((remove a) rs x)}]})))) - -(test ((remove Nat) { >} )) - -(define $remove-collection - (lambda [$a] - (lambda [$xs $ys] - (match ys (List a) - {[ xs] - [ ((remove-collection a) ((remove a) xs y) rs)]})))) - -(test ((remove-collection Nat) { > >>} { >>})) - -(define $subcollection - (lambda [$xs] - (match xs (List Something) - {[ {{}}] - [ - (let {[$subs (subcollection rs)]} - {@subs @(map (lambda [$sub] {x @sub}) - subs)})] - }))) - -(test (subcollection { > >>})) - -(define $Multiset - (lambda [$a] - (type - {[$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)] - {[[ ] ] - [[ - ] - ] - [[_ _] ]}))] - }))) - -(define $one-pair - (lambda [$ns] - (match ns (Multiset Nat) - {[> - ] - [_ ] - }))) - -(test (one-pair { > })) - -(define $full-house - (lambda [$ns] - (match ns (Multiset Nat) - {[ - >>>>> - ] - [_ ] - }))) - -(test (full-house { > >})) - -(define $thirteen >>>>>>>>>>>>>) - -(define $Card - (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[card [Suit (Mod thirteen)] - {[ {[s n]}]}]})] - [$= ]})) - -(define $poker-hands - (lambda [$Cs] - (match Cs (Multiset Card) - {[ - - - - - ! - >>>>> - ] - [ - - ! - ! - ! - >>>>> - ] - [ - - - ! - ! - ! - >>>>> - ] - [ - ! - ! - ! - ! - ! - >>>>> - ] - [ - - - - - ! - >>>>> - ] - [ - - - ! - >>>>> - ] - [ - - ! - - ! - >>>>> - ] - [ - - ! - >>>>> - ] - [ - >>>>> - ]}))) - -(define $poker-hands-without-strait - (lambda [$Cs] - (match Cs (Multiset Card) - {[ - - ! - ! - ! - >>>>> - ] - [ - - - ! - ! - ! - >>>>> - ] - [ - ! - ! - ! - ! - ! - >>>>> - ] - [ - - - ! - >>>>> - ] - [ - - ! - - ! - >>>>> - ] - [ - - ! - >>>>> - ] - [ - >>>>> - ]}))) - -(test (poker-hands-without-strait { > - >> - > - > - >>})) - -(define $car - (lambda [$as] - (match as (List Something) - {[ a]}))) - -(define $reverse - (lambda [$as] - (match as (List Something) - {[ {}] - [ - {@(reverse rs) a}]}))) diff --git a/sample/nat-test.egi b/sample/nat-test.egi deleted file mode 100644 --- a/sample/nat-test.egi +++ /dev/null @@ -1,78 +0,0 @@ -(define $Nat - (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (deconstructor - {[o [] - {[ {[]}] - [_ {}] - }] - [s [Nat] - {[ {x}] - [_ {}] - }] - })] - [$= - (lambda [$val $tgt] - (match [val tgt] [Nat Nat] - {[[ ] ] - [[ ] (= n1 n2)] - [[_ _] ]}))] - })) - -(test ((type-ref Nat =) )) - -(define $+ - (lambda [$m $n] - (match m Nat - {[ n] - [ ]}))) - -(define $* - (lambda [$m $n] - (match m Nat - {[ ] - [> n] - [ (+ n (* m1 n))]}))) - -(define $fact - (lambda [$n] - (match n Nat - {[ >] - [ (* n (fact n1))]}))) - -(test (fact >>>)) - -(define $fib - (lambda [$n] - (match n Nat - {[ >] - [> >] - [> (+ (fib ) (fib n1))]}))) - -(test (fib >>>>>>)) - -(define $val-match-test - (lambda [$n] - (match n Nat - {[,(+ > >>) ] - [$n1 n1]}))) - -(test (val-match-test >>>)) - -(define $on-pat-test - (lambda [$m $n] - (match [m n] [Nat Nat] - {[[$m1 (on [$m1] )] m1] - [[_ _] ]}))) - -(test (on-pat-test >)) - -(define $on-pat-test2 - (lambda [$m $n] - (match [m n] [Nat Nat] - {[[$m1 ] m1] - [[_ _] ]}))) - -(test (on-pat-test2 >)) -