|
| 1 | +module SimpleASTParserLog.Main where |
| 2 | + |
| 3 | +import Prelude hiding (between) |
| 4 | + |
| 5 | +import Control.Alt ((<|>)) |
| 6 | +import Control.Lazy (defer, fix) |
| 7 | +import Data.Either (Either(..)) |
| 8 | +import Data.Foldable (foldMap, for_, oneOf) |
| 9 | +import Data.Function (on) |
| 10 | +import Data.Int (fromString, toNumber) |
| 11 | +import Data.Maybe (Maybe(..)) |
| 12 | +import Data.String.CodeUnits (drop, take) |
| 13 | +import Data.String.CodeUnits as SCU |
| 14 | +import Effect (Effect) |
| 15 | +import Effect.Console (log) |
| 16 | +import Global (isFinite, readFloat) |
| 17 | +import Text.Parsing.StringParser (Parser, fail, try, unParser) |
| 18 | +import Text.Parsing.StringParser.CodeUnits (anyDigit, char, skipSpaces, string) |
| 19 | +import Text.Parsing.StringParser.Combinators (between, many1, (<?>)) |
| 20 | + |
| 21 | +-- | Language only supports the following: |
| 22 | +-- | - basic binary operations (e.g. +, -, /, *) |
| 23 | +-- | - literal integers or numbers (e.g. 4, 4.0), which cannot use a thousandth |
| 24 | +-- | separator (e.g. `10000` not `10,000`) |
| 25 | +-- | - parenthesis |
| 26 | +mathProblems :: Array String |
| 27 | +mathProblems = |
| 28 | + [ "1 + 2 * 3 - 4 / 5" |
| 29 | + , "(-1) + 2 - ((3 + 4) - 5) * (-(6 + 7 * (8 + 9))) / -10" |
| 30 | + , "-1 + -2 - -3 - -4 * 4 * 5 * -6" |
| 31 | + ] |
| 32 | + |
| 33 | +-- | Set this to `true` if you want to see the structure printed to the console |
| 34 | +-- | as well. |
| 35 | +showStructure :: Boolean |
| 36 | +showStructure = true |
| 37 | + |
| 38 | +main :: Effect Unit |
| 39 | +main = do |
| 40 | + for_ mathProblems \prob -> do |
| 41 | + log "" -- add a blank line as separator |
| 42 | + log $ "Problem is: " <> prob |
| 43 | + case unParser parseExpr {str:prob, pos: 0} of |
| 44 | + Left e -> do |
| 45 | + log $ show e.error <> |
| 46 | + "\nleft side: `" <> take e.pos prob <> |
| 47 | + "\nright side: `" <> drop e.pos prob <> "`" |
| 48 | + Right r -> do |
| 49 | + log $ (show $ evalExpr r.result) <> " = " <> printExpr r.result |
| 50 | + when showStructure do |
| 51 | + log $ "Structure is: " <> show r.result |
| 52 | + |
| 53 | +-- The Parser below uses a "precedence climbing" approach |
| 54 | + |
| 55 | +data Expr |
| 56 | + = BinaryOp Expr BinaryOperator Expr |
| 57 | + | UnaryOp UnaryExpr |
| 58 | + |
| 59 | +data BinaryOperator = Plus | Minus | Multiply | Divide |
| 60 | +data Sign = Negative | Positive |
| 61 | + |
| 62 | +data UnaryExpr |
| 63 | + = Unary Sign Atom |
| 64 | + |
| 65 | +data Atom |
| 66 | + = LitInt Int |
| 67 | + | LitNum Number |
| 68 | + | Parenthesis Expr |
| 69 | + |
| 70 | +-- Parsers |
| 71 | + |
| 72 | +parseExpr :: Parser Expr |
| 73 | +parseExpr = fix \parseInfix -> do |
| 74 | + left <- UnaryOp <$> lazyParseUnaryExpr |
| 75 | + try (parseRightHandSide left parseInfix) <|> pure left |
| 76 | + where |
| 77 | + lazyParseUnaryExpr :: Parser UnaryExpr |
| 78 | + lazyParseUnaryExpr = defer \_ -> parseUnaryExpr |
| 79 | + |
| 80 | + operatorPrecedence :: BinaryOperator -> Int |
| 81 | + operatorPrecedence = case _ of |
| 82 | + Plus -> 1 |
| 83 | + Minus -> 1 |
| 84 | + Multiply -> 2 |
| 85 | + Divide -> 2 |
| 86 | + |
| 87 | + parseRightHandSide :: Expr -> Parser Expr -> Parser Expr |
| 88 | + parseRightHandSide left parseInfix = do |
| 89 | + leftOp <- try $ between skipSpaces skipSpaces parseBinaryOperator |
| 90 | + nextPart <- parseInfix |
| 91 | + pure case nextPart of |
| 92 | + UnaryOp right -> do |
| 93 | + -- no need to handle operator precedence on a UnaryExpr |
| 94 | + BinaryOp left leftOp nextPart |
| 95 | + |
| 96 | + BinaryOp middle rightOp right -> |
| 97 | + -- Evaluation runs from left to right. Ensure we have fully evaluated |
| 98 | + -- the left part before we evaluate the right part by reassociating |
| 99 | + -- terms with the correct operations. |
| 100 | + case (compare `on` operatorPrecedence) leftOp rightOp of |
| 101 | + LT -> do |
| 102 | + -- No term reassociation here because leftOp < rightOp |
| 103 | + -- For example |
| 104 | + -- `1 + 2 * 4` becomes `(1 + (2 * 4))` |
| 105 | + BinaryOp left leftOp nextPart |
| 106 | + |
| 107 | + _ {- GT or EQ -} -> do |
| 108 | + -- Always reassociate terms here |
| 109 | + -- For example: |
| 110 | + -- `1 * 2 + 4` becomes `((1 * 2) + 4)` |
| 111 | + BinaryOp (BinaryOp left leftOp middle) rightOp right |
| 112 | + |
| 113 | + parseBinaryOperator :: Parser BinaryOperator |
| 114 | + parseBinaryOperator = do |
| 115 | + oneOf [ Multiply <$ string "*" |
| 116 | + , Divide <$ string "/" |
| 117 | + , Plus <$ string "+" |
| 118 | + , Minus <$ string "-" |
| 119 | + , fail "Could not parse a binary operator" |
| 120 | + ] |
| 121 | + |
| 122 | +parseUnaryExpr :: Parser UnaryExpr |
| 123 | +parseUnaryExpr = do |
| 124 | + sign <- (Negative <$ char '-') <|> pure Positive |
| 125 | + atom <- lazyParseAtom |
| 126 | + pure $ Unary sign atom |
| 127 | + where |
| 128 | + lazyParseAtom :: Parser Atom |
| 129 | + lazyParseAtom = defer \_ -> parseAtom |
| 130 | + |
| 131 | +parseAtom :: Parser Atom |
| 132 | +parseAtom = do |
| 133 | + parseLiteral <|> parseParenthesis |
| 134 | + where |
| 135 | + parseNumber :: String -> Parser Atom |
| 136 | + parseNumber digitsAsString = do |
| 137 | + void $ string "." -- decimal point |
| 138 | + decimalsAsString <- parseNumSequence |
| 139 | + let fullString = digitsAsString <> "." <> decimalsAsString |
| 140 | + case readFloat fullString of |
| 141 | + x | isFinite x -> pure $ LitNum x |
| 142 | + _ -> fail $ "Not a valid decimal: " <> fullString |
| 143 | + |
| 144 | + parseInt :: String -> Parser Atom |
| 145 | + parseInt digitsAsString = case fromString digitsAsString of |
| 146 | + Just i -> pure $ LitInt i |
| 147 | + Nothing -> fail $ |
| 148 | + "String of digit characters `" <> digitsAsString <> |
| 149 | + "` is outside the bounds of `Int`" |
| 150 | + |
| 151 | + parseLiteral :: Parser Atom |
| 152 | + parseLiteral = do |
| 153 | + digitsAsString <- parseNumSequence |
| 154 | + try (parseNumber digitsAsString) <|> (parseInt digitsAsString) |
| 155 | + |
| 156 | + lazyParseExpr :: Parser Expr |
| 157 | + lazyParseExpr = defer \_ -> parseExpr |
| 158 | + |
| 159 | + parseParenthesis :: Parser Atom |
| 160 | + parseParenthesis = do |
| 161 | + between (char '(') (char ')') do |
| 162 | + between skipSpaces skipSpaces do |
| 163 | + Parenthesis <$> lazyParseExpr |
| 164 | + |
| 165 | +parseNumSequence :: Parser String |
| 166 | +parseNumSequence = do |
| 167 | + digitCharList <- (many1 anyDigit) <?> "Did not find 1 or more digit characters" |
| 168 | + pure $ foldMap SCU.singleton digitCharList |
| 169 | + |
| 170 | +-- Evaluators |
| 171 | + |
| 172 | +evalExpr :: Expr -> Number |
| 173 | +evalExpr = case _ of |
| 174 | + BinaryOp l op r -> (evalOp op) (evalExpr l) (evalExpr r) |
| 175 | + UnaryOp unaryExpr -> evalUnaryExpr unaryExpr |
| 176 | + where |
| 177 | + evalOp :: forall a. EuclideanRing a => BinaryOperator -> (a -> a -> a) |
| 178 | + evalOp = case _ of |
| 179 | + Plus -> (+) |
| 180 | + Minus -> (-) |
| 181 | + Multiply -> (*) |
| 182 | + Divide -> (/) |
| 183 | + |
| 184 | +evalUnaryExpr :: UnaryExpr -> Number |
| 185 | +evalUnaryExpr = case _ of |
| 186 | + Unary sign atom -> case sign of |
| 187 | + Positive -> evalAtom atom |
| 188 | + Negative -> negate (evalAtom atom) |
| 189 | + |
| 190 | +evalAtom :: Atom -> Number |
| 191 | +evalAtom = case _ of |
| 192 | + LitInt i -> toNumber i |
| 193 | + LitNum n -> n |
| 194 | + Parenthesis expr -> evalExpr expr |
| 195 | + |
| 196 | +-- Printers |
| 197 | + |
| 198 | +printExpr :: Expr -> String |
| 199 | +printExpr = case _ of |
| 200 | + BinaryOp l op r -> (printExpr l) <> " " <> (printOp op) <> " " <> (printExpr r) |
| 201 | + UnaryOp unaryExpr -> printUnaryExpr unaryExpr |
| 202 | + where |
| 203 | + printOp :: BinaryOperator -> String |
| 204 | + printOp = case _ of |
| 205 | + Plus -> "+" |
| 206 | + Minus -> "-" |
| 207 | + Multiply -> "*" |
| 208 | + Divide -> "/" |
| 209 | + |
| 210 | +printUnaryExpr :: UnaryExpr -> String |
| 211 | +printUnaryExpr = case _ of |
| 212 | + Unary sign atom -> case sign of |
| 213 | + Positive -> printAtom atom |
| 214 | + Negative -> "-" <> (printAtom atom) |
| 215 | + |
| 216 | +printAtom :: Atom -> String |
| 217 | +printAtom = case _ of |
| 218 | + LitInt i -> show i |
| 219 | + LitNum n -> show n |
| 220 | + Parenthesis expr -> "(" <> printExpr expr <> ")" |
| 221 | + |
| 222 | +-- type class instances |
| 223 | + |
| 224 | +derive instance eqUnaryExpr :: Eq UnaryExpr |
| 225 | +derive instance ordUnaryExpr :: Ord UnaryExpr |
| 226 | +instance showUnaryExpr :: Show UnaryExpr where |
| 227 | + show (Unary sign atom) = "Unary(" <> show sign <> " " <> show atom <> ")" |
| 228 | + |
| 229 | +derive instance eqAtom :: Eq Atom |
| 230 | +derive instance ordAtom :: Ord Atom |
| 231 | +instance showAtom :: Show Atom where |
| 232 | + show = case _ of |
| 233 | + LitInt i -> "LitInt " <> show i |
| 234 | + LitNum n -> "LitNum " <> show n |
| 235 | + Parenthesis content -> "Parenthesis(" <> show content <> ")" |
| 236 | + |
| 237 | +derive instance eqExpr :: Eq Expr |
| 238 | +derive instance ordExpr :: Ord Expr |
| 239 | +instance showExpr :: Show Expr where |
| 240 | + show = case _ of |
| 241 | + BinaryOp l op r -> |
| 242 | + "BinaryOp(" <> show l <> " " <> show op <> " " <> show r <> ")" |
| 243 | + UnaryOp unary -> "UnaryOp(" <> show unary <> ")" |
| 244 | + |
| 245 | +derive instance eqBinaryOperator :: Eq BinaryOperator |
| 246 | +derive instance ordBinaryOperator :: Ord BinaryOperator |
| 247 | +instance showBinaryOperator :: Show BinaryOperator where |
| 248 | + show = case _ of |
| 249 | + Plus -> "+" |
| 250 | + Minus -> "-" |
| 251 | + Multiply -> "*" |
| 252 | + Divide -> "/" |
| 253 | + |
| 254 | +derive instance eqSign :: Eq Sign |
| 255 | +derive instance ordSign :: Ord Sign |
| 256 | +instance showSign :: Show Sign where |
| 257 | + show = case _ of |
| 258 | + Positive -> "Positive" |
| 259 | + Negative -> "Negative" |
0 commit comments