From d8751f2cced8f14366533ff0dbbc62fa73ec8665 Mon Sep 17 00:00:00 2001 From: Charles Date: Mon, 16 Mar 2020 10:50:03 +0100 Subject: Clean parser for expression containing rational and imaginary --- src/atom.hs | 4 ++ src/complex.hs | 17 ------- src/context.hs | 22 --------- src/expr.hs | 38 +++++++++++++++ src/imag.hs | 6 --- src/matrix.hs | 3 -- src/parser.hs | 131 ++++++++++++++++++++++---------------------------- src/parser/complex.hs | 0 src/parser/matrix.hs | 0 src/rational.hs | 3 -- 10 files changed, 100 insertions(+), 124 deletions(-) delete mode 100644 src/complex.hs delete mode 100644 src/context.hs create mode 100644 src/expr.hs delete mode 100644 src/imag.hs delete mode 100644 src/matrix.hs delete mode 100644 src/parser/complex.hs delete mode 100644 src/parser/matrix.hs delete mode 100644 src/rational.hs (limited to 'src') diff --git a/src/atom.hs b/src/atom.hs index d01b157..5f1b42c 100644 --- a/src/atom.hs +++ b/src/atom.hs @@ -30,6 +30,10 @@ _ /? (ARational 0) = Nothing (ARational a) /? (ARational b) = Just $ ARational (a / b) _ /? _ = Nothing +infixl 7 %? +(%?) :: Atom -> Atom -> Maybe Atom +_ %? _ = Nothing + infixr 8 ^? (^?) :: Atom -> Atom -> Maybe Atom (ARational a) ^? (ARational b) = Just $ ARational (a ** b) diff --git a/src/complex.hs b/src/complex.hs deleted file mode 100644 index 220fe1f..0000000 --- a/src/complex.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Complex where - -type Imaginary = Float - -data Complex = Complex Float Imaginary - --- instance Num Complex where --- (Complex r1 i1) + (Complex r2 i2) = Complex (r1 + r2) (i1 + i2) --- (Complex r1 i1) * (Complex r2 i2) = undefined --- negate (Complex r1 i1) = undefined --- abs (Complex r1 i1) = undefined --- signum (Complex r1 i1) = undefined - -- fromInteger r = Complex r 0 - -instance Show Complex where - show (Complex r i) = show r ++ showI ++ "i" - where showI = if i < 0 then " - " ++ show (-i) else " + " ++ show i diff --git a/src/context.hs b/src/context.hs deleted file mode 100644 index c5abfe0..0000000 --- a/src/context.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Context where - -import Data.List -import Control.Alternative - -type Label = String -data State a = State [a] -data Context a = Context [Decl] a - -instance Functor Context where - fmap f (Context state x) = Context (f x) state - -getLabel :: Declaration a => State a -> Label -> Maybe a -getLabel (State decls) l = find (label . (l ==)) decls - -class Declaration a where - label :: a -> Label - -- value for variable - -- partial expression where the only variable left is the argument - resolve :: a -> State -> b - - diff --git a/src/expr.hs b/src/expr.hs new file mode 100644 index 0000000..87a700b --- /dev/null +++ b/src/expr.hs @@ -0,0 +1,38 @@ +module Expr where + +import Atom + + +data Expr + = EAtom Atom + | Add Expr Expr + | Sub Expr Expr + | Mul Expr Expr + | Div Expr Expr + | Mod Expr Expr + | Exp Expr Expr + -- | Dot Expr Expr + + +eval :: Expr -> Maybe Atom +eval (EAtom a) = Just a +eval (Add e1 e2) = evalBin e1 e2 (+?) +eval (Sub e1 e2) = evalBin e1 e2 (-?) +eval (Mul e1 e2) = evalBin e1 e2 (*?) +eval (Div e1 e2) = evalBin e1 e2 (/?) +eval (Mod e1 e2) = evalBin e1 e2 (%?) +eval (Exp e1 e2) = evalBin e1 e2 (^?) + +evalBin :: Expr -> Expr -> (Atom -> Atom -> Maybe Atom) -> Maybe Atom +evalBin e1 e2 f = do a <- eval e1 + b <- eval e2 + f a b + +instance Show Expr where + show (EAtom a) = show a + show (Add e1 e2) = show e1 ++ " + " ++ show e2 + show (Sub e1 e2) = show e1 ++ " - " ++ show e2 + show (Mul e1 e2) = show e1 ++ " * " ++ show e2 + show (Div e1 e2) = show e1 ++ " / " ++ show e2 + show (Mod e1 e2) = show e1 ++ " % " ++ show e2 + show (Exp e1 e2) = show e1 ++ " ^ " ++ show e2 diff --git a/src/imag.hs b/src/imag.hs deleted file mode 100644 index 16ac28e..0000000 --- a/src/imag.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Imag where - --- newtype Imag = Imag { getImag :: Float } - --- instance Show Imag where --- show (Imag i) = show i ++ "i" diff --git a/src/matrix.hs b/src/matrix.hs deleted file mode 100644 index 7de634b..0000000 --- a/src/matrix.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Matrix where - - diff --git a/src/parser.hs b/src/parser.hs index 64f452a..405ff9b 100644 --- a/src/parser.hs +++ b/src/parser.hs @@ -4,15 +4,14 @@ import Control.Applicative import Control.Monad import Data.Char +import Atom import Expr -import Imag -import Matrix +newtype Parser a = Parser { parse :: String -> Maybe (a, String) } -newtype Parser a = Parser (String -> Maybe (a, String)) - -parse :: Parser a -> String -> Maybe (a, String) -parse (Parser p) input = p input +parseStrict :: Parser a -> String -> Maybe a +parseStrict p input = case parse p input of Just (a, "") -> Just a + _ -> Nothing instance Functor Parser where -- fmap :: (a -> b) -> Parser a -> Parser b @@ -54,11 +53,22 @@ satisfyChar f = Parser p p (c:cs) = if f c then Just (c, cs) else Nothing -sepBy :: Parser b -> Parser a -> Parser [a] -sepBy sep x = (:) <$> x <*> (many (sep *> x)) +-- sepBy :: Parser b -> Parser a -> Parser [a] +-- sepBy sep x = (:) <$> x <*> (many (sep *> x)) +-- sepByMap :: (b -> a -> a) -> Parser b -> Parser a -> Parser [a] +-- sepByMap f sep x = (:) <$> x <*> (many (f <$> sep <*> x)) + +chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a +chainl p op a = chainl1 p op <|> pure a + +chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a +chainl1 p op = do first <- p + rest first + where rest prev = do f <- op + e <- p + rest (f prev e) + <|> return prev -sepByMap :: (b -> a -> a) -> Parser b -> Parser a -> Parser [a] -sepByMap f sep x = (:) <$> x <*> (many (f <$> sep <*> x)) signed :: Num a => Parser a -> Parser a signed p = do charP '-' x <- p @@ -68,9 +78,18 @@ signed p = do charP '-' readParser :: Read a => Parser String -> Parser a readParser p = read <$> p +infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a) +infixOp opStr f = stringP opStr *> pure f + +parenthesize :: Parser a -> Parser a +parenthesize p = charP '(' *> p <* charP ')' + charP :: Char -> Parser Char charP c = satisfyChar (c ==) +stringP :: String -> Parser String +stringP s = sequenceA $ charP <$> s + alphaP :: Parser Char alphaP = satisfyChar isAlpha @@ -97,67 +116,33 @@ unsignedFloatP = readParser p floatP :: Parser Float floatP = signed unsignedFloatP -imagP :: Parser Imag -imagP = Imag <$> (floatP <* charP 'i') - -matrixP :: Parser (Matrix AExpr) -matrixP = Matrix <$> (charP '[' *> (sepBy (charP ';') matrixRowP) <* charP ']') - -matrixRowP :: Parser (MatrixRow AExpr) -matrixRowP = charP '[' *> (sepBy (charP ',') aExprP) <* charP ']' - -varP :: Parser Var -varP = some alphaP - -funcExprP :: Parser FuncExpr -funcExprP = do name <- varP - charP '(' - arg <- aExprP - charP ')' - return (FuncExpr name arg) - -aExprP :: Parser AExpr -aExprP = do x <- termP - charP '+' - y <- aExprP - return (AExpr x y) - <|> (AExprSingle <$> termP) - -termP :: Parser Term -termP = do f <- factorP - charP '*' - t <- termP - return (Term f t) - <|> (TermSingle <$> factorP) - - -factorP :: Parser Factor -factorP = do b <- baseP - charP '^' - e <- factorP - return (Factor b e) - <|> (FactorSingle <$> baseP) - -baseP :: Parser Base -baseP = (charP '(' *> (Base <$> aExprP) <* charP ')') - <|> (BaseSingle <$> ExprI <$> imagP) - <|> (BaseSingle <$> ExprF <$> floatP) - <|> (BaseSingle <$> ExprM <$> matrixP) - <|> (BaseSingle <$> ExprFE <$> funcExprP) - <|> (BaseSingle <$> ExprV <$> varP) - -funcDeclP :: Parser FuncDecl -funcDeclP = do name <- varP - charP '(' - argName <- varP - charP ')' - return (FuncDecl name argName) - -labelP :: Parser Label -labelP = varP <|> funcDeclP - -evalP :: Parser Eval -evalP = do labelP - charP '=' - (EvalDecl <$> exprP) <|> (EvalTry <$ charP '?') +imaginaryP :: Parser Atom +imaginaryP = AImaginary <$> (floatP <* charP 'i') + +rationalP :: Parser Atom +rationalP = ARational <$> floatP + +termOpP :: Parser (Expr -> Expr -> Expr) +termOpP = infixOp "+" Add <|> infixOp "-" Sub + +factorOpP :: Parser (Expr -> Expr -> Expr) +factorOpP = infixOp "*" Mul <|> infixOp "/" Div <|> infixOp "%" Mod + +expOpP :: Parser (Expr -> Expr -> Expr) +expOpP = infixOp "^" Exp + +exprP :: Parser Expr +exprP = termP `chainl1` termOpP + +termP :: Parser Expr +termP = factorP `chainl1` factorOpP + +factorP :: Parser Expr +factorP = endpointP `chainl1` expOpP + where endpointP = parenthesisP <|> (EAtom <$> atomP) + +parenthesisP :: Parser Expr +parenthesisP = parenthesize exprP +atomP :: Parser Atom +atomP = imaginaryP <|> rationalP diff --git a/src/parser/complex.hs b/src/parser/complex.hs deleted file mode 100644 index e69de29..0000000 diff --git a/src/parser/matrix.hs b/src/parser/matrix.hs deleted file mode 100644 index e69de29..0000000 diff --git a/src/rational.hs b/src/rational.hs deleted file mode 100644 index 7eb1785..0000000 --- a/src/rational.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Rational where - -type Rational = Float -- cgit