From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 6 Jul 2018 13:40:43 +0000 (+0200)
Subject: Initial commit
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=191a9ff967e46f4aaefda2a059a713ffc6ac389b;p=fp.git

Initial commit
---

191a9ff967e46f4aaefda2a059a713ffc6ac389b
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