From: Mart Lubbers Date: Mon, 11 Mar 2019 07:26:53 +0000 (+0100) Subject: parse X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=52b07dd4f4a5821ec016d82f8df442109217c1ce;p=clean-tests.git parse --- 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'])