"Fossies" - the Fresh Open Source Software Archive

Member "pp-2.14.3/src/Expr.hs" (24 Nov 2021, 3872 Bytes) of package /linux/privat/pp-2.14.3.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Haskell source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "Expr.hs": 2.14.2_vs_2.14.3.

    1 {- PP
    2 
    3 Copyright (C) 2015-2021 Christophe Delord
    4 
    5 http://cdelord.fr/pp
    6 
    7 This file is part of PP.
    8 
    9 PP is free software: you can redistribute it and/or modify
   10 it under the terms of the GNU General Public License as published by
   11 the Free Software Foundation, either version 3 of the License, or
   12 (at your option) any later version.
   13 
   14 PP is distributed in the hope that it will be useful,
   15 but WITHOUT ANY WARRANTY; without even the implied warranty of
   16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   17 GNU General Public License for more details.
   18 
   19 You should have received a copy of the GNU General Public License
   20 along with PP.  If not, see <http://www.gnu.org/licenses/>.
   21 -}
   22 
   23 module Expr ( eval
   24             )
   25 where
   26 
   27 import Data.Bool
   28 import Data.Functor.Identity
   29 import Text.ParserCombinators.Parsec
   30 import Text.Parsec
   31 import Text.Parsec.Expr
   32 import Text.Parsec.Token
   33 import Text.Parsec.Language (javaStyle)
   34 
   35 import ErrorMessages
   36 
   37 data V = Z Integer | S String
   38 
   39 lexer :: GenTokenParser String u Identity
   40 lexer = makeTokenParser javaStyle
   41 
   42 expr :: ParsecT String u Identity V
   43 expr = buildExpressionParser table term <?> "expression"
   44 
   45 term :: ParsecT String u Identity V
   46 term = parens lexer expr
   47      <|> braces lexer expr
   48      <|> brackets lexer expr
   49      <|> (Z <$> integer lexer)
   50      <|> (S <$> stringLiteral lexer)
   51      <|> (S <$> identifier lexer)
   52      <?> "term"
   53 
   54 table :: [[Operator String u Identity V]]
   55 table = [ [prefix "-" (op1 negate), prefix "+" (op1 id)]
   56         , [binary "*" (op2 (*)) AssocLeft, binary "/" (op2 div) AssocLeft]
   57         , [binary "+" (op2 (+)) AssocLeft, binary "-" (op2 (-)) AssocLeft]
   58         , [prefix "!" (bool1 not), prefix "not" (bool1 not)]
   59         , [binary "&&" (bool2 (&&)) AssocLeft, binary "and" (bool2 (&&)) AssocLeft]
   60         , [binary "||" (bool2 (||)) AssocLeft, binary "or" (bool2 (||)) AssocLeft]
   61         , [binary "xor" (bool2 (/=)) AssocLeft]
   62         , [ binary "==" (rel (==) (==)) AssocLeft
   63           , binary "/=" (rel (/=) (/=)) AssocLeft
   64           , binary "!=" (rel (/=) (/=)) AssocLeft
   65           , binary "<=" (rel (<=) (<=)) AssocLeft
   66           , binary "<" (rel (<) (<)) AssocLeft
   67           , binary ">=" (rel (>=) (>=)) AssocLeft
   68           , binary ">" (rel (>) (>)) AssocLeft
   69           ]
   70         ]
   71 
   72 binary :: String -> (a -> a -> a) -> Assoc -> Operator String u Identity a
   73 binary name fun = Infix (do { reservedOp lexer name; return fun })
   74 prefix :: String -> (a -> a) -> Operator String u Identity a
   75 prefix name fun = Prefix (do { reservedOp lexer name; return fun })
   76 
   77 op1 :: (Integer -> Integer) -> V -> V
   78 op1 op (Z x) = Z $ op x
   79 op1 op (S s) = Z $ op $ atoi s
   80 
   81 op2 :: (Integer -> Integer -> Integer) -> V -> V -> V
   82 op2 op (Z x) (Z y) = Z $ op x y
   83 op2 op (Z x) (S y) = Z $ op x (atoi y)
   84 op2 op (S x) (Z y) = Z $ op (atoi x) y
   85 op2 op (S x) (S y) = Z $ op (atoi x) (atoi y)
   86 
   87 b :: Bool -> V
   88 b = Z . bool 0 1
   89 
   90 bool1 :: (Bool -> Bool) -> V -> V
   91 bool1 op (Z x) = b $ op (x /= 0)
   92 bool1 op (S s) = b $ op (s /= "")
   93 
   94 bool2 :: (Bool -> Bool -> Bool) -> V -> V -> V
   95 bool2 op (Z x) (Z y) = b $ op (x /= 0) (y /= 0)
   96 bool2 op (Z x) (S y) = b $ op (x /= 0) (y /= "")
   97 bool2 op (S x) (Z y) = b $ op (x /= "") (y /= 0)
   98 bool2 op (S x) (S y) = b $ op (x /= "") (y /= "")
   99 
  100 rel :: (Integer -> Integer -> Bool) -> (String -> String -> Bool) -> V -> V -> V
  101 rel ri _rs (Z x) (Z y) = b $ ri x y
  102 rel _ri rs (Z x) (S y) = b $ rs (show x) y
  103 rel _ri rs (S x) (Z y) = b $ rs x (show y)
  104 rel _ri rs (S x) (S y) = b $ rs x y
  105 
  106 atoi :: String -> Integer
  107 atoi s = case reads s of
  108             [(i, "")] -> i
  109             _ -> 0
  110 
  111 contents :: Parser a -> Parser a
  112 contents p = do
  113     r <- p
  114     eof
  115     return r
  116 
  117 eval :: SourceName -> String -> (String, Bool)
  118 eval source expression = case parse (contents expr) source expression of
  119     Right (Z n) -> (show n, n /= 0)
  120     Right (S s) -> (s, not (null s))
  121     Left _ -> exprError expression