From: Mart Lubbers Date: Mon, 9 Jul 2018 07:26:37 +0000 (+0200) Subject: add infix and preamble X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=571fe71ca22f9cc1b24ef504d202ce44c616047f;p=fp.git add infix and preamble --- diff --git a/ast.dcl b/ast.dcl index 510434c..a24b2df 100644 --- a/ast.dcl +++ b/ast.dcl @@ -8,6 +8,8 @@ definition module ast = Literal Value | Variable String | Apply Expression Expression + | Lambda String Expression + | Code String | .. :: Value diff --git a/ast.icl b/ast.icl index 419c3e9..3f52921 100644 --- a/ast.icl +++ b/ast.icl @@ -15,6 +15,8 @@ where pretty (Literal v) = pretty v pretty (Variable v) = string v pretty (Apply a b) = parens (pretty a <+> pretty b) + pretty (Lambda a b) = string "\\" <-> string a <-> string "->" <-> pretty b + pretty (Code b) = string "code" <+> string b instance Pretty Function where diff --git a/parse.icl b/parse.icl index 17524d1..e5927bd 100644 --- a/parse.icl +++ b/parse.icl @@ -26,7 +26,8 @@ derive consName Token, Value :: Token = IntToken Int | BoolToken Bool | CharToken Char | IdentToken String | InfixrToken | InfixlToken | SemiColonToken | OpenBraceToken - | CloseBraceToken | EqualsToken + | CloseBraceToken | EqualsToken | CodeToken | LambdaToken + | ArrowToken lex :: [Char] -> [Token] lex cs = lex` cs @@ -40,8 +41,11 @@ where | not (isIdent c) = [EqualsToken:lex` [c:cs]] lex` ['(':cs] = [OpenBraceToken:lex` cs] lex` [')':cs] = [CloseBraceToken:lex` cs] + lex` ['-','>':cs] = [ArrowToken:lex` cs] + lex` ['\\':cs] = [LambdaToken:lex` cs] lex` ['\'',c,'\'':cs] = [CharToken c:lex` cs] lex` ['T','r','u','e':cs] = [BoolToken True:lex` cs] + lex` ['c','o','d','e':cs] = [CodeToken:lex` cs] lex` ['F','a','l','s','e':cs] = [BoolToken True:lex` cs] lex` ['i','n','f','i','x','r':cs] = [InfixrToken:lex` cs] lex` ['i','n','f','i','x','l':cs] = [InfixlToken:lex` cs] @@ -57,8 +61,13 @@ where | isIdent c # (i, cs) = span (\c->isIdent c || isDigit c) cs = [IdentToken $ toString [c:i]:lex` cs] + | isFunny c + # (i, cs) = span (\c->isFunny c || isDigit c) cs + = [IdentToken $ toString [c:i]:lex` cs] + = abort $ "Huh lexer failed on: " +++ toString (toInt c) -isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`='] +isIdent c = isAlpha c || elem c ['\'`'] +isFunny = flip elem ['!@#$%^&*\|+-?/\'<>.:~='] :: ParseState = { tokens :: [Token] @@ -103,26 +112,49 @@ cons x xs = [x:xs] parseExpr :: Parser Expression parseExpr = gets (\s->sort s.infixers) - >>= flip seq parseBasic o cons parseApp o reverse o map op2parser + >>= foldr ($) parseBasic o (\x xs->[x:xs]) parseApp o map op2parser where + op2parser :: Infix -> ((Parser Expression) -> Parser Expression) op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP - (\l op->Apply $ Apply op l) (Variable <$> parseIf ((==)sym) parseIdent) + (\l op->Apply (Apply op l)) $ Variable <$> parseIf ((==)sym) parseIdent + parseApp :: ((Parser Expression) -> Parser Expression) parseApp = parseLOP (const o Apply) (pure ()) parseLOP :: (a b a -> a) (c b) (c a) -> c a | Alternative c - parseLOP comb ops prev = foldl (uncurry o comb) - <$> prev <*> many (tuple <$> ops <*> prev) + parseLOP comb ops prev = foldl (uncurry o comb) <$> prev <*> many (tuple <$> ops <*> prev) parseROP :: (a b a -> a) (c b) (c a) -> c a | Monad c & Alternative c - parseROP comb ops prev = prev >>= \e1-> - comb e1 <$> ops <*> parseROP comb ops prev <|> pure e1 + parseROP comb ops prev = prev >>= \e1->comb e1 <$> ops <*> parseROP comb ops prev <|> pure e1 + parseBasic :: Parser Expression parseBasic - = (token OpenBraceToken *> parseExpr <* token CloseBraceToken) + //Bracketed + = token OpenBraceToken *> parseBracketed <* token CloseBraceToken <|> Literal <$> Int <$> parseInt - <|> (gets (\s->[i\\Infix i _ _<-s.infixers]) - >>= \ifs->Variable <$> parseIf (not o flip elem ifs) parseIdent) + <|> Code <$> (token CodeToken *> parseIdent) + <|> flip (foldr Lambda) <$> (token LambdaToken *> some parseIdent <* token ArrowToken) <*> parseExpr + <|> Variable <$> parseWithIfx ((o) not o flip elem) + + parseBracketed :: Parser Expression + parseBracketed + //Curried prefix infix + = (\e op->Apply (Apply fpflip op) e) <$> parseIfx <*> parseExpr + //Regular Prefix infix + <|> parseIfx + //Curried flipped prefix infix + <|> Apply <$> parseExpr <*> parseIfx + //Parse regular expression + <|> parseExpr + + fpflip :: Expression + fpflip = Lambda "x" $ Lambda "y" $ Lambda "z" $ Apply (Apply (Variable "x") (Variable "z")) (Variable "y") + + parseWithIfx :: ([String] String -> Bool) -> Parser String + parseWithIfx f = gets (\s->[i\\Infix i _ _<-s.infixers]) >>= flip parseIf parseIdent o f + + parseIfx :: Parser Expression + parseIfx = Variable <$> parseWithIfx (flip elem) parseAST :: Parser AST parseAST = AST <$> many parseFunction @@ -145,4 +177,20 @@ parseIdent = (\(IdentToken s)->s) <$> token (IdentToken "") parseInt :: Parser Int parseInt = (\(IntToken i)->i) <$> token (IntToken 0) -Start = toString <$> parse (lex ['+ infixr 6 a b = 0; * infixr 7 a b = 0; ap = a + b * c + d;']) zero +Start = + toString <$> parse ( + lex $ + ['id x = x;'] ++ + ['const x y = x;'] ++ + ['flip x y z = x z y;'] ++ + ['. infixr 9 f g x = f $ g x;'] ++ + ['$ infixr 0 = id;'] ++ + ['& infixr 0 = flip $;'] ++ + ['+ infixr 6 = code add;'] ++ + ['- infixr 6 = code sub;'] ++ + ['* infixr 7 = code mul;'] ++ + ['/ infixr 7 = code div;'] ++ + ['&& infixl 3 = code and;'] ++ + ['|| infixl 2 = code or;'] ++ + ['ap = f . g $ x;'] + ) zero