never executed always true always false

    1 {- |
    2 Module      : NITTA.Frontends.XMILE.MathParser
    3 Description : Parses XMILE math equations
    4 Copyright   : (c) Artur Gogiyan, 2022
    5 License     : BSD3
    6 Maintainer  : artur.gogiyan@gmail.com
    7 Stability   : experimental
    8 -}
    9 module NITTA.Frontends.XMILE.MathParser (
   10     parseXmileEquation,
   11     calculateDefaultValue,
   12     XMExpr (..),
   13     XMDuop (..),
   14 ) where
   15 
   16 import Data.HashMap.Strict qualified as HM
   17 import Data.Maybe (fromMaybe)
   18 import Data.Text as T
   19 import Text.Parsec
   20 import Text.Parsec.Expr
   21 import Text.Parsec.Language
   22 import Text.Parsec.String
   23 import Text.Parsec.Token
   24 import Text.Read hiding (parens)
   25 
   26 data XMExpr = Var String | Val Double | Duo {xmeOp :: XMDuop, xmeLexpr, xmeRexpr :: XMExpr}
   27     deriving (Show, Eq)
   28 
   29 data XMDuop = Mul | Div | Add | Sub deriving (Show, Eq)
   30 
   31 languageDef =
   32     emptyDef
   33         { identStart = letter <|> space <|> digit <|> char '\"'
   34         , identLetter = letter <|> space <|> digit <|> char '.'
   35         , opStart = oneOf "+-/*"
   36         , opLetter = oneOf "+-/*"
   37         , reservedOpNames = ["+", "-", "/", "*"]
   38         , reservedNames = ["true", "false"]
   39         }
   40 
   41 TokenParser
   42     { parens = m_parens
   43     , identifier = m_identifier
   44     , reservedOp = m_reservedOp
   45     } = makeTokenParser languageDef
   46 
   47 parseXmileEquation eqn = case parse exprparser "" eqn of
   48     Right e -> prepareTree e
   49     Left _ -> error $ "error while parsing XMILE equation : " <> eqn
   50 
   51 exprparser :: Parser XMExpr
   52 exprparser = buildExpressionParser table term <?> "expression"
   53 table =
   54     [ [Infix (m_reservedOp "*" >> return (Duo Mul)) AssocLeft]
   55     , [Infix (m_reservedOp "/" >> return (Duo Div)) AssocLeft]
   56     , [Infix (m_reservedOp "+" >> return (Duo Add)) AssocLeft]
   57     , [Infix (m_reservedOp "-" >> return (Duo Sub)) AssocLeft]
   58     ]
   59 term =
   60     m_parens exprparser <|> fmap Var (between (skipMany (char '\"')) (skipMany (char '\"' <|> space)) m_identifier)
   61 
   62 trimString str = T.unpack $ T.map repl $ T.strip $ T.pack str
   63     where
   64         repl ' ' = '_'
   65         repl c = c
   66 
   67 prepareTree (Var str) = maybe (Var $ trimString str) Val $ readMaybe str
   68 prepareTree v@(Val _) = v
   69 prepareTree (Duo op a b) = Duo op (prepareTree a) (prepareTree b)
   70 
   71 calculateDefaultValue _ (Val value) = value
   72 calculateDefaultValue defaultValues (Var name) = fromMaybe 0 $ HM.lookup (T.pack name) defaultValues
   73 calculateDefaultValue defaultValues e@(Duo op expl expr) =
   74     let leftValue = calculateDefaultValue defaultValues expl
   75         rightValue = calculateDefaultValue defaultValues expr
   76      in case op of
   77             Mul -> leftValue * rightValue
   78             Div
   79                 | rightValue == 0 -> error ("division to zero in expression '" <> show e <> "'")
   80                 | otherwise -> leftValue / rightValue
   81             Add -> leftValue + rightValue
   82             Sub -> leftValue - rightValue