parse

diff --git a/csg/p.icl b/csg/p.icl
new file mode 100644 (file)
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 (file)
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'])