From 191a9ff967e46f4aaefda2a059a713ffc6ac389b Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Fri, 6 Jul 2018 15:40:43 +0200 Subject: [PATCH] Initial commit --- ast.dcl | 21 ++++++++ ast.icl | 31 ++++++++++++ parse.dcl | 13 +++++ parse.icl | 145 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 210 insertions(+) create mode 100644 ast.dcl create mode 100644 ast.icl create mode 100644 parse.dcl create mode 100644 parse.icl diff --git a/ast.dcl b/ast.dcl new file mode 100644 index 0000000..510434c --- /dev/null +++ b/ast.dcl @@ -0,0 +1,21 @@ +definition module ast + +:: AST = AST [Function] + +:: Function = Function String [String] Expression + +:: Expression + = Literal Value + | Variable String + | Apply Expression Expression + | .. + +:: Value + = Int Int + | Bool Bool + | Char Char + +instance toString AST +instance toString Function +instance toString Expression +instance toString Value diff --git a/ast.icl b/ast.icl new file mode 100644 index 0000000..419c3e9 --- /dev/null +++ b/ast.icl @@ -0,0 +1,31 @@ +implementation module ast + +import StdList +import StdOverloaded +import Data.Func +import Text.PPrint + +instance toString AST where toString a = display $ renderCompact $ pretty a +instance toString Function where toString a = display $ renderCompact $ pretty a +instance toString Expression where toString a = display $ renderCompact $ pretty a +instance toString Value where toString a = display $ renderCompact $ pretty a + +instance Pretty Expression +where + pretty (Literal v) = pretty v + pretty (Variable v) = string v + pretty (Apply a b) = parens (pretty a <+> pretty b) + +instance Pretty Function +where + pretty (Function n args a) = string n <+> fold (<+>) (map string args) <+> string "=" <+> pretty a + +instance Pretty AST +where + pretty (AST a) = pretty a + +instance Pretty Value +where + pretty (Int i) = int i + pretty (Bool b) = bool b + pretty (Char c) = char c diff --git a/parse.dcl b/parse.dcl new file mode 100644 index 0000000..9ac10cd --- /dev/null +++ b/parse.dcl @@ -0,0 +1,13 @@ +definition module parse + +from ast import :: AST +from Data.Either import :: Either +from StdOverloaded import class zero + +:: Token +:: ParseState + +instance zero ParseState + +lex :: [Char] -> [Token] +parse :: [Token] ParseState -> Either [String] AST diff --git a/parse.icl b/parse.icl new file mode 100644 index 0000000..521b355 --- /dev/null +++ b/parse.icl @@ -0,0 +1,145 @@ +implementation module parse + +import StdEnv +import qualified _SystemStrictLists as SS +import StdStrictLists +import ast + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Data.Data +import Data.Maybe +import Data.Either +import Data.Func +import Data.Functor +import Data.Bifunctor +import Data.GenCons +import Data.List +import Data.Monoid +import Data.Tuple + +derive consName Token, Value + +:: Expression | DelayedParse [Token] + +:: Token + = IntToken Int | BoolToken Bool | CharToken Char | IdentToken String + | InfixrToken | InfixlToken | SemiColonToken | OpenBraceToken + | CloseBraceToken | EqualsToken + +lex :: [Char] -> [Token] +lex cs = lex` cs +where + lex` [] = [] + lex` ['\n':cs] = lex` cs + lex` [c:cs] + | isSpace c = lex` cs + lex` [';':cs] = [SemiColonToken:lex` cs] + lex` ['=':cs] = [EqualsToken:lex` cs] + lex` ['(':cs] = [OpenBraceToken:lex` cs] + lex` [')':cs] = [CloseBraceToken:lex` cs] + lex` ['\'',c,'\'':cs] = [CharToken c:lex` cs] + lex` ['T','r','u','e':cs] = [BoolToken True: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] + lex` ['-',c:cs] + | isDigit c + = case lex` [c:cs] of + [IntToken i:ts] = [IntToken (~i):ts] + ts = ts + lex` [c:cs] + | isDigit c + # (i, cs) = span isDigit [c:cs] + = [IntToken $ toInt $ toString i:lex` cs] + | isIdent c + # (i, cs) = span (\c->isIdent c || isDigit c) cs + = [IdentToken $ toString [c:i]:lex` cs] + where + isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`='] + +:: ParseState = + { tokens :: [Token] + , infixers :: [Infix] + } +:: Infix = Infix String Fixity Int +instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t +:: Fixity = InfixL | InfixR + +:: Parser a :== StateT ParseState (Either [String]) a + +instance zero ParseState where zero = {tokens=[],infixers=[]} + +() infixl 1 :: a (StateT b (Either (c a)) d) -> StateT b (Either (c a)) d | Semigroup (c a) & Applicative c +() err p = StateT $ first (flip mappend (pure err)) o runStateT p + +top :: Parser Token +top = getState >>= \st=:{tokens}->case tokens of + [t:ts] = put {st & tokens=ts} >>| pure t + _ = empty + +parseIf :: (a -> Bool) (Parser a) -> Parser a +parseIf pred p = p >>= \a->if (pred a) (pure a) empty + +satisfy p :== parseIf p top +token t :== satisfy ((=+?=)t) + +(until) infix 5 :: (Parser a) (Parser b) -> Parser ([a], b) +(until) p grd = (tuple [] <$> grd) <|> (appFst o 'SS'._cons <$> p <*> p until grd) + +parse :: [Token] ParseState -> Either [String] AST +parse ts st = runStateT parseAST {st & tokens=ts} >>= uncurry parse2 + +parse2 :: AST ParseState -> Either [String] AST +parse2 (AST fs) ps = AST <$> mapM pfun fs +where + pfun :: Function -> Either [String] Function + pfun (Function s a (DelayedParse ts)) = + Function s a <$> evalStateT parseExpr {ps & tokens=ts} + pfun x = pure x + +parseExpr :: Parser Expression +parseExpr = gets (\s->sort s.infixers) >>= foldr ($) parseApp o map op2parser +where + op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP + (\l op->Apply $ Apply op l) (Variable <$> parseIf ((==)sym) parseIdent) + + parseApp = parseLOP (const o Apply) (pure ()) parseBasic + + parseLOP comb ops prev = prev + >>= \e1->many (tuple <$> ops <*> prev) + >>= foldM (\e->pure o uncurry (comb e)) e1 + + parseROP comb ops prev = prev + >>= \e1->optional (tuple <$> ops <*> parseROP comb ops prev) + >>= pure o maybe e1 (\(op,e2)->comb e1 op e2)//uncurry (comb e1)) + + parseBasic + = (token OpenBraceToken *> parseExpr <* token CloseBraceToken) + <|> Literal <$> Int <$> parseInt + <|> (gets (\s->[i\\Infix i _ _<-s.infixers]) + >>= \ifs->Variable <$> parseIf (not o flip elem ifs) parseIdent) + +parseAST :: Parser AST +parseAST = AST <$> many parseFunction + +parseFunction :: Parser Function +parseFunction = Function + <$> (parseIdent >>= \ident->(parseFixity ident <|> pure ()) >>| pure ident) + <*> many parseIdent + <*> (DelayedParse o fst <$> (token EqualsToken *> top until token SemiColonToken)) + +parseFixity :: String -> Parser () +parseFixity ident = Infix ident + <$> (token InfixrToken *> pure InfixR <|> token InfixlToken *> pure InfixL) + <*> parseInt + >>= \f->modify \s->{s & infixers=[f:s.infixers]} + +parseIdent :: Parser String +parseIdent = (\(IdentToken s)->s) <$> token (IdentToken "") + +parseInt :: Parser Int +parseInt = (\(IntToken i)->i) <$> token (IntToken 0) + +Start = toString <$> parse (lex ['$ infixr 0 a b = -42; ap a b = a $ b $ c; ap a b = a b c;']) zero -- 2.20.1