Initial commit

diff --git a/ast.dcl b/ast.dcl
new file mode 100644 (file)
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 (file)
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 (file)
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 (file)
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