From 52b07dd4f4a5821ec016d82f8df442109217c1ce Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 11 Mar 2019 08:26:53 +0100
Subject: [PATCH] parse

---
 csg/p.icl          | 101 +++++++++++++++++++++++++++++++++++++++++++++
 exprparse/test.icl |  32 ++++++++++++++
 2 files changed, 133 insertions(+)
 create mode 100644 csg/p.icl
 create mode 100644 exprparse/test.icl

diff --git a/csg/p.icl b/csg/p.icl
new file mode 100644
index 0000000..334d1cd
--- /dev/null
+++ b/csg/p.icl
@@ -0,0 +1,101 @@
+module p
+
+import StdEnv
+
+import Data.Func
+import Data.Functor
+import Data.Tuple
+import Data.Maybe
+import Control.Applicative
+import Control.Monad
+
+:: Parser m a = Parser (ParseState -> m (a, ParseState))
+:: ParseState =
+	{ tokens   :: [Char]
+	, infixers :: [Infixer]
+	}
+:: Infixer = Infxer Bool Int [Char]
+
+runParser :: (Parser m a) -> (ParseState -> m (a, ParseState))
+runParser (Parser a) = a
+
+instance Functor (Parser m) | Monad m where fmap a b = liftM a b
+instance pure (Parser m) | Monad m where pure a = Parser (pure o tuple a)
+instance <*> (Parser m) | Monad m where (<*>) a b = ap a b
+instance <* (Parser m) | Monad m
+instance *> (Parser m) | Monad m
+instance Monad (Parser m) | Monad m where
+	bind ma a2mb = Parser \c->runParser ma c >>= uncurry (runParser o a2mb)
+instance Alternative (Parser m) | Alternative m where
+	empty = Parser (pure empty)
+	(<|>) l r = Parser \c->runParser l c <|> runParser r c
+
+get :: Parser m ParseState | Alternative, Monad m
+get = Parser \c->pure (c, c)
+
+set :: ParseState -> Parser m () | Alternative, Monad m
+set c = Parser \_->pure ((), c)
+
+upd :: (ParseState -> ParseState) -> Parser m () | Alternative, Monad m
+upd f = f <$> get >>= set
+
+pTop :: Parser m Char | Alternative, Monad m
+pTop = get >>= \c->case c.tokens of
+	[] = empty
+	[t:ts] = set {c & tokens=ts} *> pure t
+
+pSatisfy :: (Char -> Bool) -> Parser m Char | Alternative, Monad m
+pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
+
+pToken :: Char -> Parser m Char | Alternative, Monad m
+pToken c = pSatisfy ((==)c)
+
+(<:>) infixr 1
+(<:>) l r :== (\x xs->[x:xs]) <$> l <*> r
+
+pTokens :: [Char] -> Parser m [Char] | Alternative, Monad m
+pTokens ts = foldr (<:>) (pure []) (map pToken ts)
+
+pChainL :: (Parser m (a a -> a)) (Parser m a) -> Parser m a | Alternative, Monad m
+pChainL op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
+
+:: Program :== [([Char], Expr)]
+:: Expr
+	= Var [Char]
+	| Lit Int
+	| BinOp [Char] Expr Expr
+
+pProgram :: Parser m Program | Alternative, Monad m
+pProgram = many pDecl
+
+pDecl :: Parser m ([Char], Expr) | Alternative, Monad m
+pDecl = tuple <$> many (pSatisfy isAlpha) <* pToken '=' <*> pExpr <* pToken '\n'
+
+pInfixer :: Parser m Program | Alternative, Monad m
+pInfixer = Infxer o (==) 'r' <$ pTokens ['ifx'] <*> (pToken 'r' <|> pToken 'l') <*> pLit <*> many (pSatisfy isOpChar)
+	>>= \_->pure []
+
+pExpr :: Parser m Expr | Alternative, Monad m
+pExpr = pChainL (BinOp <$> pTokens ['+']) $
+	    Lit <$> pLit
+	<|> Var <$> many (pSatisfy isAlpha)
+	<|> pToken '(' *> pExpr <* pToken ')'
+
+pLit :: Parser m Int | Alternative, Monad m
+pLit = ((~) <$ pToken '-' <|> pure id) <*>
+	(toInt <$> toString <$> some (pSatisfy isDigit))
+
+isOpChar :: Char -> Bool
+isOpChar c = isMember c ['-+*/%@#$^&=|\'']
+
+printProgram :: [([Char], Expr)] -> String
+printProgram p = foldr (+++) ""
+	[toString c +++ "=" +++ printExpr e\\(c, e)<-p]
+
+printExpr :: Expr -> String
+printExpr (Var i) = toString i
+printExpr (Lit i) = toString i
+printExpr (BinOp o l r) = "(" +++ printExpr l +++ toString o +++ printExpr r +++ ")"
+
+Start :: Maybe (String, ParseState)
+Start = appFst printProgram <$> runParser pProgram {tokens=['y=x+4\n'],infixers=[]}
diff --git a/exprparse/test.icl b/exprparse/test.icl
new file mode 100644
index 0000000..72f4de9
--- /dev/null
+++ b/exprparse/test.icl
@@ -0,0 +1,32 @@
+module test
+
+import StdEnv
+
+import Data.Functor
+import Control.Applicative
+
+import Text.Parsers.Simple.Core
+import Text.Parsers.Simple.Chars
+
+preprocess :: [Char] -> [Char]
+preprocess c = ['((((':foldr prep ['))))'] c]
+where
+	prep '(' cs = ['(','(','(','(':cs]
+	prep ')' cs = [')',')',')',')':cs]
+	prep '^' cs = [')','^','(':cs]
+	prep '*' cs = [')',')','*','(','(':cs]
+	prep '/' cs = [')',')','/','(','(':cs]
+	prep '+' cs = [')',')',')','+','(','(','(':cs]
+	prep '-' cs = [')',')',')','-','(','(','(':cs]
+	prep c cs   = [c:cs]
+
+:: Expr = BinOp Expr Char Expr | Lit Int | Var [Char]
+
+parseExpr :: Parser Char Expr
+parseExpr
+	=   BinOp <$ pToken '(' <*> parseExpr <*> pOneOf ['^*/+-'] <*> parseExpr <* pToken ')'
+	<|> Var <$> some pAlpha
+	<|> Lit o toInt o toString <$> some pDigit
+
+Start = parse parseExpr (preprocess ['a'])
+//Start = parse parseExpr (preprocess ['a*b+c^d/e'])
-- 
2.20.1