{-# LANGUAGE ConstraintKinds, RankNTypes, ScopedTypeVariables #-}
-- | An expression language corresponding to the subset of C syntax
-- that may be used in preprocessor conditional directives. See
-- <https://gcc.gnu.org/onlinedocs/cpp/If.html>
module Hpp.Expr (Expr(..), readLitInt, parseExpr, renderExpr, evalExpr) where
import Control.Applicative
import Control.Monad ((>=>))
import Data.Bits (complement, (.&.), (.|.), xor, shiftL, shiftR)
import Data.List (foldl')
import Text.Read (readMaybe)
import Hpp.Tokens
import Data.Char (digitToInt, toLower)
import Data.Proxy (Proxy(..))
import Data.Bifunctor (bimap)
import Data.Bits (Bits)

-- * Token Parsing Types

data BinOp = Add | Sub | Mul | Div | Mod
           | BitAnd | BitOr | BitXor | ShiftL | ShiftR
           | LessThan | GreaterThan | EqualTo | NotEqualTo
           | GreaterOrEqualTo | LessOrEqualTo
           | And | Or
             deriving (BinOp -> BinOp -> Bool
(BinOp -> BinOp -> Bool) -> (BinOp -> BinOp -> Bool) -> Eq BinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinOp -> BinOp -> Bool
$c/= :: BinOp -> BinOp -> Bool
== :: BinOp -> BinOp -> Bool
$c== :: BinOp -> BinOp -> Bool
Eq, Eq BinOp
Eq BinOp
-> (BinOp -> BinOp -> Ordering)
-> (BinOp -> BinOp -> Bool)
-> (BinOp -> BinOp -> Bool)
-> (BinOp -> BinOp -> Bool)
-> (BinOp -> BinOp -> Bool)
-> (BinOp -> BinOp -> BinOp)
-> (BinOp -> BinOp -> BinOp)
-> Ord BinOp
BinOp -> BinOp -> Bool
BinOp -> BinOp -> Ordering
BinOp -> BinOp -> BinOp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BinOp -> BinOp -> BinOp
$cmin :: BinOp -> BinOp -> BinOp
max :: BinOp -> BinOp -> BinOp
$cmax :: BinOp -> BinOp -> BinOp
>= :: BinOp -> BinOp -> Bool
$c>= :: BinOp -> BinOp -> Bool
> :: BinOp -> BinOp -> Bool
$c> :: BinOp -> BinOp -> Bool
<= :: BinOp -> BinOp -> Bool
$c<= :: BinOp -> BinOp -> Bool
< :: BinOp -> BinOp -> Bool
$c< :: BinOp -> BinOp -> Bool
compare :: BinOp -> BinOp -> Ordering
$ccompare :: BinOp -> BinOp -> Ordering
$cp1Ord :: Eq BinOp
Ord, Int -> BinOp -> ShowS
[BinOp] -> ShowS
BinOp -> String
(Int -> BinOp -> ShowS)
-> (BinOp -> String) -> ([BinOp] -> ShowS) -> Show BinOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinOp] -> ShowS
$cshowList :: [BinOp] -> ShowS
show :: BinOp -> String
$cshow :: BinOp -> String
showsPrec :: Int -> BinOp -> ShowS
$cshowsPrec :: Int -> BinOp -> ShowS
Show)

data UnaryOp = Neg | BitNot | Not | Defined deriving (UnaryOp -> UnaryOp -> Bool
(UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool) -> Eq UnaryOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnaryOp -> UnaryOp -> Bool
$c/= :: UnaryOp -> UnaryOp -> Bool
== :: UnaryOp -> UnaryOp -> Bool
$c== :: UnaryOp -> UnaryOp -> Bool
Eq,Eq UnaryOp
Eq UnaryOp
-> (UnaryOp -> UnaryOp -> Ordering)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> Bool)
-> (UnaryOp -> UnaryOp -> UnaryOp)
-> (UnaryOp -> UnaryOp -> UnaryOp)
-> Ord UnaryOp
UnaryOp -> UnaryOp -> Bool
UnaryOp -> UnaryOp -> Ordering
UnaryOp -> UnaryOp -> UnaryOp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnaryOp -> UnaryOp -> UnaryOp
$cmin :: UnaryOp -> UnaryOp -> UnaryOp
max :: UnaryOp -> UnaryOp -> UnaryOp
$cmax :: UnaryOp -> UnaryOp -> UnaryOp
>= :: UnaryOp -> UnaryOp -> Bool
$c>= :: UnaryOp -> UnaryOp -> Bool
> :: UnaryOp -> UnaryOp -> Bool
$c> :: UnaryOp -> UnaryOp -> Bool
<= :: UnaryOp -> UnaryOp -> Bool
$c<= :: UnaryOp -> UnaryOp -> Bool
< :: UnaryOp -> UnaryOp -> Bool
$c< :: UnaryOp -> UnaryOp -> Bool
compare :: UnaryOp -> UnaryOp -> Ordering
$ccompare :: UnaryOp -> UnaryOp -> Ordering
$cp1Ord :: Eq UnaryOp
Ord,Int -> UnaryOp -> ShowS
[UnaryOp] -> ShowS
UnaryOp -> String
(Int -> UnaryOp -> ShowS)
-> (UnaryOp -> String) -> ([UnaryOp] -> ShowS) -> Show UnaryOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnaryOp] -> ShowS
$cshowList :: [UnaryOp] -> ShowS
show :: UnaryOp -> String
$cshow :: UnaryOp -> String
showsPrec :: Int -> UnaryOp -> ShowS
$cshowsPrec :: Int -> UnaryOp -> ShowS
Show)

data Lit = LitInt Int | LitUInt Word | LitStr String | LitChar Char | LitID String
           deriving (Lit -> Lit -> Bool
(Lit -> Lit -> Bool) -> (Lit -> Lit -> Bool) -> Eq Lit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lit -> Lit -> Bool
$c/= :: Lit -> Lit -> Bool
== :: Lit -> Lit -> Bool
$c== :: Lit -> Lit -> Bool
Eq,Eq Lit
Eq Lit
-> (Lit -> Lit -> Ordering)
-> (Lit -> Lit -> Bool)
-> (Lit -> Lit -> Bool)
-> (Lit -> Lit -> Bool)
-> (Lit -> Lit -> Bool)
-> (Lit -> Lit -> Lit)
-> (Lit -> Lit -> Lit)
-> Ord Lit
Lit -> Lit -> Bool
Lit -> Lit -> Ordering
Lit -> Lit -> Lit
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Lit -> Lit -> Lit
$cmin :: Lit -> Lit -> Lit
max :: Lit -> Lit -> Lit
$cmax :: Lit -> Lit -> Lit
>= :: Lit -> Lit -> Bool
$c>= :: Lit -> Lit -> Bool
> :: Lit -> Lit -> Bool
$c> :: Lit -> Lit -> Bool
<= :: Lit -> Lit -> Bool
$c<= :: Lit -> Lit -> Bool
< :: Lit -> Lit -> Bool
$c< :: Lit -> Lit -> Bool
compare :: Lit -> Lit -> Ordering
$ccompare :: Lit -> Lit -> Ordering
$cp1Ord :: Eq Lit
Ord,Int -> Lit -> ShowS
[Lit] -> ShowS
Lit -> String
(Int -> Lit -> ShowS)
-> (Lit -> String) -> ([Lit] -> ShowS) -> Show Lit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lit] -> ShowS
$cshowList :: [Lit] -> ShowS
show :: Lit -> String
$cshow :: Lit -> String
showsPrec :: Int -> Lit -> ShowS
$cshowsPrec :: Int -> Lit -> ShowS
Show)

data Parsed = PBinOp BinOp | PUnaryOp UnaryOp | PLit Lit deriving (Parsed -> Parsed -> Bool
(Parsed -> Parsed -> Bool)
-> (Parsed -> Parsed -> Bool) -> Eq Parsed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Parsed -> Parsed -> Bool
$c/= :: Parsed -> Parsed -> Bool
== :: Parsed -> Parsed -> Bool
$c== :: Parsed -> Parsed -> Bool
Eq,Eq Parsed
Eq Parsed
-> (Parsed -> Parsed -> Ordering)
-> (Parsed -> Parsed -> Bool)
-> (Parsed -> Parsed -> Bool)
-> (Parsed -> Parsed -> Bool)
-> (Parsed -> Parsed -> Bool)
-> (Parsed -> Parsed -> Parsed)
-> (Parsed -> Parsed -> Parsed)
-> Ord Parsed
Parsed -> Parsed -> Bool
Parsed -> Parsed -> Ordering
Parsed -> Parsed -> Parsed
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Parsed -> Parsed -> Parsed
$cmin :: Parsed -> Parsed -> Parsed
max :: Parsed -> Parsed -> Parsed
$cmax :: Parsed -> Parsed -> Parsed
>= :: Parsed -> Parsed -> Bool
$c>= :: Parsed -> Parsed -> Bool
> :: Parsed -> Parsed -> Bool
$c> :: Parsed -> Parsed -> Bool
<= :: Parsed -> Parsed -> Bool
$c<= :: Parsed -> Parsed -> Bool
< :: Parsed -> Parsed -> Bool
$c< :: Parsed -> Parsed -> Bool
compare :: Parsed -> Parsed -> Ordering
$ccompare :: Parsed -> Parsed -> Ordering
$cp1Ord :: Eq Parsed
Ord,Int -> Parsed -> ShowS
[Parsed] -> ShowS
Parsed -> String
(Int -> Parsed -> ShowS)
-> (Parsed -> String) -> ([Parsed] -> ShowS) -> Show Parsed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Parsed] -> ShowS
$cshowList :: [Parsed] -> ShowS
show :: Parsed -> String
$cshow :: Parsed -> String
showsPrec :: Int -> Parsed -> ShowS
$cshowsPrec :: Int -> Parsed -> ShowS
Show)

-- * Integers

-- | If one side of an operator is unsigned, the other side is converted
-- to unsigned.
newtype CppInt = CppInt { CppInt -> Either Word Int
getCppInt :: Either Word Int }

onCommonType :: forall p c. (c Word, c Int)
             => p c
             -> (forall a. c a => a -> a -> a)
             -> CppInt -> CppInt -> CppInt
onCommonType :: p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType p c
_ forall a. c a => a -> a -> a
f (CppInt (Right Int
x)) (CppInt (Right Int
y)) = Either Word Int -> CppInt
CppInt (Int -> Either Word Int
forall a b. b -> Either a b
Right (Int -> Int -> Int
forall a. c a => a -> a -> a
f Int
x Int
y))
onCommonType p c
_ forall a. c a => a -> a -> a
f (CppInt (Left Word
x)) (CppInt (Left Word
y)) = Either Word Int -> CppInt
CppInt (Word -> Either Word Int
forall a b. a -> Either a b
Left (Word -> Word -> Word
forall a. c a => a -> a -> a
f Word
x Word
y))
onCommonType p c
_ forall a. c a => a -> a -> a
f (CppInt (Right Int
x)) (CppInt (Left Word
y)) =
  Either Word Int -> CppInt
CppInt (Word -> Either Word Int
forall a b. a -> Either a b
Left (Word -> Either Word Int) -> Word -> Either Word Int
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word
forall a. c a => a -> a -> a
f (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) Word
y)
onCommonType p c
_ forall a. c a => a -> a -> a
f (CppInt (Left Word
x)) (CppInt (Right Int
y)) =
  Either Word Int -> CppInt
CppInt (Word -> Either Word Int
forall a b. a -> Either a b
Left (Word -> Either Word Int) -> Word -> Either Word Int
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word
forall a. c a => a -> a -> a
f Word
x (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y))

instance Eq CppInt where
  CppInt (Left Word
x) == :: CppInt -> CppInt -> Bool
== CppInt (Right Int
y) = Word
x Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y
  CppInt (Right Int
x) == CppInt (Left Word
y) = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
y
  CppInt Either Word Int
x == CppInt Either Word Int
y = Either Word Int
x Either Word Int -> Either Word Int -> Bool
forall a. Eq a => a -> a -> Bool
== Either Word Int
y

onCommonTypeB :: forall p c. (c Word, c Int)
              => p c
              -> (forall a. c a => a -> a -> Bool)
              -> CppInt -> CppInt -> Bool
onCommonTypeB :: p c
-> (forall a. c a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
onCommonTypeB p c
_ forall a. c a => a -> a -> Bool
f (CppInt (Right Int
x)) (CppInt (Right Int
y)) = Int -> Int -> Bool
forall a. c a => a -> a -> Bool
f Int
x Int
y
onCommonTypeB p c
_ forall a. c a => a -> a -> Bool
f (CppInt (Left Word
x)) (CppInt (Left Word
y)) = Word -> Word -> Bool
forall a. c a => a -> a -> Bool
f Word
x Word
y
onCommonTypeB p c
_ forall a. c a => a -> a -> Bool
f (CppInt (Right Int
x)) (CppInt (Left Word
y)) = Word -> Word -> Bool
forall a. c a => a -> a -> Bool
f (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) Word
y
onCommonTypeB p c
_ forall a. c a => a -> a -> Bool
f (CppInt (Left Word
x)) (CppInt (Right Int
y)) = Word -> Word -> Bool
forall a. c a => a -> a -> Bool
f Word
x (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)

instance Ord CppInt where
  CppInt
x < :: CppInt -> CppInt -> Bool
< CppInt
y = Proxy Ord
-> (forall a. Ord a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c
-> (forall a. c a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
onCommonTypeB (Proxy Ord
forall k (t :: k). Proxy t
Proxy::Proxy Ord) forall a. Ord a => a -> a -> Bool
(<) CppInt
x CppInt
y
  CppInt
x > :: CppInt -> CppInt -> Bool
> CppInt
y = Proxy Ord
-> (forall a. Ord a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c
-> (forall a. c a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
onCommonTypeB (Proxy Ord
forall k (t :: k). Proxy t
Proxy::Proxy Ord) forall a. Ord a => a -> a -> Bool
(>) CppInt
x CppInt
y
  CppInt
x <= :: CppInt -> CppInt -> Bool
<= CppInt
y = Proxy Ord
-> (forall a. Ord a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c
-> (forall a. c a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
onCommonTypeB (Proxy Ord
forall k (t :: k). Proxy t
Proxy::Proxy Ord) forall a. Ord a => a -> a -> Bool
(<=) CppInt
x CppInt
y
  CppInt
x >= :: CppInt -> CppInt -> Bool
>= CppInt
y = Proxy Ord
-> (forall a. Ord a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c
-> (forall a. c a => a -> a -> Bool) -> CppInt -> CppInt -> Bool
onCommonTypeB (Proxy Ord
forall k (t :: k). Proxy t
Proxy::Proxy Ord) forall a. Ord a => a -> a -> Bool
(>=) CppInt
x CppInt
y
  max :: CppInt -> CppInt -> CppInt
max CppInt
x CppInt
y = Proxy Ord
-> (forall a. Ord a => a -> a -> a) -> CppInt -> CppInt -> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Ord
forall k (t :: k). Proxy t
Proxy::Proxy Ord) forall a. Ord a => a -> a -> a
max CppInt
x CppInt
y
  min :: CppInt -> CppInt -> CppInt
min CppInt
x CppInt
y = Proxy Ord
-> (forall a. Ord a => a -> a -> a) -> CppInt -> CppInt -> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Ord
forall k (t :: k). Proxy t
Proxy::Proxy Ord) forall a. Ord a => a -> a -> a
min CppInt
x CppInt
y

instance Num CppInt where
  CppInt
x + :: CppInt -> CppInt -> CppInt
+ CppInt
y = Proxy Num
-> (forall a. Num a => a -> a -> a) -> CppInt -> CppInt -> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Num
forall k (t :: k). Proxy t
Proxy::Proxy Num) forall a. Num a => a -> a -> a
(+) CppInt
x CppInt
y
  CppInt
x - :: CppInt -> CppInt -> CppInt
- CppInt
y = Proxy Num
-> (forall a. Num a => a -> a -> a) -> CppInt -> CppInt -> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Num
forall k (t :: k). Proxy t
Proxy::Proxy Num) (-) CppInt
x CppInt
y
  CppInt
x * :: CppInt -> CppInt -> CppInt
* CppInt
y = Proxy Num
-> (forall a. Num a => a -> a -> a) -> CppInt -> CppInt -> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Num
forall k (t :: k). Proxy t
Proxy::Proxy Num) forall a. Num a => a -> a -> a
(*) CppInt
x CppInt
y
  negate :: CppInt -> CppInt
negate (CppInt Either Word Int
x) = Either Word Int -> CppInt
CppInt (Int -> Either Word Int
forall a b. b -> Either a b
Right (Int -> Either Word Int) -> Int -> Either Word Int
forall a b. (a -> b) -> a -> b
$ (Word -> Int) -> (Int -> Int) -> Either Word Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (Word -> Int) -> Word -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int -> Int
forall a. Num a => a -> a
negate Either Word Int
x)
  abs :: CppInt -> CppInt
abs (CppInt Either Word Int
x) = Either Word Int -> CppInt
CppInt ((Word -> Word)
-> (Int -> Int) -> Either Word Int -> Either Word Int
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Word -> Word
forall a. Num a => a -> a
abs Int -> Int
forall a. Num a => a -> a
abs Either Word Int
x)
  signum :: CppInt -> CppInt
signum (CppInt Either Word Int
x) = Either Word Int -> CppInt
CppInt ((Word -> Word)
-> (Int -> Int) -> Either Word Int -> Either Word Int
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Word -> Word
forall a. Num a => a -> a
signum Int -> Int
forall a. Num a => a -> a
signum Either Word Int
x)
  fromInteger :: Integer -> CppInt
fromInteger = Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt)
-> (Integer -> Either Word Int) -> Integer -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either Word Int
forall a b. b -> Either a b
Right (Int -> Either Word Int)
-> (Integer -> Int) -> Integer -> Either Word Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger

integralCpp :: (forall a. Integral a => a -> a -> a) -> CppInt -> CppInt -> CppInt
integralCpp :: (forall a. Integral a => a -> a -> a) -> CppInt -> CppInt -> CppInt
integralCpp = Proxy Integral
-> (forall a. Integral a => a -> a -> a)
-> CppInt
-> CppInt
-> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Integral
forall k (t :: k). Proxy t
Proxy::Proxy Integral)

bitsCpp :: (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt
bitsCpp :: (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt
bitsCpp = Proxy Bits
-> (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt
forall (p :: (* -> Constraint) -> *) (c :: * -> Constraint).
(c Word, c Int) =>
p c -> (forall a. c a => a -> a -> a) -> CppInt -> CppInt -> CppInt
onCommonType (Proxy Bits
forall k (t :: k). Proxy t
Proxy::Proxy Bits)

cppShiftL,cppShiftR :: CppInt -> Int -> CppInt
cppShiftL :: CppInt -> Int -> CppInt
cppShiftL (CppInt Either Word Int
x) Int
s = Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt) -> Either Word Int -> CppInt
forall a b. (a -> b) -> a -> b
$ (Word -> Word)
-> (Int -> Int) -> Either Word Int -> Either Word Int
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
s) (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
s) Either Word Int
x
cppShiftR :: CppInt -> Int -> CppInt
cppShiftR (CppInt Either Word Int
x) Int
s = Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt) -> Either Word Int -> CppInt
forall a b. (a -> b) -> a -> b
$ (Word -> Word)
-> (Int -> Int) -> Either Word Int -> Either Word Int
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
s) (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
s) Either Word Int
x

cppComplement :: CppInt -> CppInt
cppComplement :: CppInt -> CppInt
cppComplement (CppInt Either Word Int
x) = Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt) -> Either Word Int -> CppInt
forall a b. (a -> b) -> a -> b
$ (Word -> Word)
-> (Int -> Int) -> Either Word Int -> Either Word Int
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Word -> Word
forall a. Bits a => a -> a
complement Int -> Int
forall a. Bits a => a -> a
complement Either Word Int
x

-- * Associativity and Precedence

data Assoc = RightLeft | LeftRight deriving (Assoc -> Assoc -> Bool
(Assoc -> Assoc -> Bool) -> (Assoc -> Assoc -> Bool) -> Eq Assoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assoc -> Assoc -> Bool
$c/= :: Assoc -> Assoc -> Bool
== :: Assoc -> Assoc -> Bool
$c== :: Assoc -> Assoc -> Bool
Eq, Eq Assoc
Eq Assoc
-> (Assoc -> Assoc -> Ordering)
-> (Assoc -> Assoc -> Bool)
-> (Assoc -> Assoc -> Bool)
-> (Assoc -> Assoc -> Bool)
-> (Assoc -> Assoc -> Bool)
-> (Assoc -> Assoc -> Assoc)
-> (Assoc -> Assoc -> Assoc)
-> Ord Assoc
Assoc -> Assoc -> Bool
Assoc -> Assoc -> Ordering
Assoc -> Assoc -> Assoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Assoc -> Assoc -> Assoc
$cmin :: Assoc -> Assoc -> Assoc
max :: Assoc -> Assoc -> Assoc
$cmax :: Assoc -> Assoc -> Assoc
>= :: Assoc -> Assoc -> Bool
$c>= :: Assoc -> Assoc -> Bool
> :: Assoc -> Assoc -> Bool
$c> :: Assoc -> Assoc -> Bool
<= :: Assoc -> Assoc -> Bool
$c<= :: Assoc -> Assoc -> Bool
< :: Assoc -> Assoc -> Bool
$c< :: Assoc -> Assoc -> Bool
compare :: Assoc -> Assoc -> Ordering
$ccompare :: Assoc -> Assoc -> Ordering
$cp1Ord :: Eq Assoc
Ord, Int -> Assoc -> ShowS
[Assoc] -> ShowS
Assoc -> String
(Int -> Assoc -> ShowS)
-> (Assoc -> String) -> ([Assoc] -> ShowS) -> Show Assoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assoc] -> ShowS
$cshowList :: [Assoc] -> ShowS
show :: Assoc -> String
$cshow :: Assoc -> String
showsPrec :: Int -> Assoc -> ShowS
$cshowsPrec :: Int -> Assoc -> ShowS
Show)

associativity :: Either BinOp UnaryOp -> Assoc
associativity :: Either BinOp UnaryOp -> Assoc
associativity = (BinOp -> Assoc)
-> (UnaryOp -> Assoc) -> Either BinOp UnaryOp -> Assoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Assoc -> BinOp -> Assoc
forall a b. a -> b -> a
const Assoc
LeftRight) (Assoc -> UnaryOp -> Assoc
forall a b. a -> b -> a
const Assoc
RightLeft)

precedence :: Either BinOp UnaryOp -> Int
precedence :: Either BinOp UnaryOp -> Int
precedence (Right UnaryOp
_) = Int
10
precedence (Left BinOp
x) = BinOp -> Int
precedenceBin BinOp
x

-- | Precedence of binary operators from lowest to highest.
precedenceBin :: BinOp -> Int
precedenceBin :: BinOp -> Int
precedenceBin BinOp
Or = Int
0
precedenceBin BinOp
And = Int
1
precedenceBin BinOp
BitOr = Int
2
precedenceBin BinOp
BitXor = Int
3
precedenceBin BinOp
BitAnd = Int
4
precedenceBin BinOp
EqualTo = Int
5
precedenceBin BinOp
NotEqualTo = Int
5
precedenceBin BinOp
LessThan = Int
6
precedenceBin BinOp
GreaterThan = Int
6
precedenceBin BinOp
GreaterOrEqualTo = Int
6
precedenceBin BinOp
LessOrEqualTo = Int
6
precedenceBin BinOp
ShiftL = Int
7
precedenceBin BinOp
ShiftR = Int
7
precedenceBin BinOp
Add = Int
8
precedenceBin BinOp
Sub = Int
8
precedenceBin BinOp
Mul = Int
9
precedenceBin BinOp
Div = Int
9
precedenceBin BinOp
Mod = Int
9

-- * Lexing

-- | String literals are split by tokenization. Fix them!
fixStringLits :: [Token String] -> Maybe [String]
fixStringLits :: [Token String] -> Maybe [String]
fixStringLits [] = [String] -> Maybe [String]
forall a. a -> Maybe a
Just []
fixStringLits (Important h :: String
h@(Char
'"':String
_):[Token String]
xs) =
  let ([Token String]
hs,[Token String]
ys) = (Token String -> Bool)
-> [Token String] -> ([Token String], [Token String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"') (Char -> Bool) -> (Token String -> Char) -> Token String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
last (String -> Char)
-> (Token String -> String) -> Token String -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token String -> String
forall s. Token s -> s
detok) [Token String]
xs
  in case [Token String]
ys of
       [] -> Maybe [String]
forall a. Maybe a
Nothing
       (Token String
y:[Token String]
ys') -> ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Token String] -> String
forall s. Monoid s => [Token s] -> s
detokenize [Token String]
hs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token String -> String
forall s. Token s -> s
detok Token String
y) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
                       ([Token String] -> Maybe [String]
fixStringLits [Token String]
ys')
fixStringLits (Important String
x:[Token String]
xs) = ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([Token String] -> Maybe [String]
fixStringLits [Token String]
xs)
fixStringLits (Other String
_ : [Token String]
xs) = [Token String] -> Maybe [String]
fixStringLits [Token String]
xs

onFirstImportant :: (String -> String)
                 -> ([Token String] -> [Token String])
                 -> [Token String]
                 -> [Token String]
onFirstImportant :: ShowS
-> ([Token String] -> [Token String])
-> [Token String]
-> [Token String]
onFirstImportant ShowS
f [Token String] -> [Token String]
k = [Token String] -> [Token String]
go
  where go :: [Token String] -> [Token String]
go [] = [Token String] -> [Token String]
k []
        go (Important String
s : [Token String]
ts') = String -> Token String
forall s. s -> Token s
Important (ShowS
f String
s) Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: [Token String] -> [Token String]
k [Token String]
ts'
        go (o :: Token String
o@(Other String
_) : [Token String]
ts') = Token String
o Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: [Token String] -> [Token String]
go [Token String]
ts'

-- | Re-combine positive and negative unary operators with the tokens
-- to which they are attached.
fixUnaryOps :: [Token String] -> [Token String]
fixUnaryOps :: [Token String] -> [Token String]
fixUnaryOps [] = []
fixUnaryOps (Token String
t0:[Token String]
ts0) =
  case Token String
t0 of
    Important String
"+" -> ShowS
-> ([Token String] -> [Token String])
-> [Token String]
-> [Token String]
onFirstImportant (Char
'+'Char -> ShowS
forall a. a -> [a] -> [a]
:) (Bool -> [Token String] -> [Token String]
go Bool
False) [Token String]
ts0
    Important String
"-" -> ShowS
-> ([Token String] -> [Token String])
-> [Token String]
-> [Token String]
onFirstImportant (Char
'-'Char -> ShowS
forall a. a -> [a] -> [a]
:) (Bool -> [Token String] -> [Token String]
go Bool
False) [Token String]
ts0
    Token String
_ -> Bool -> [Token String] -> [Token String]
go Bool
False (Token String
t0Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
:[Token String]
ts0)
  where go :: Bool -> [Token String] -> [Token String]
go Bool
_ [] = []
        go Bool
_ (Important String
"(":[Token String]
ts) = String -> Token String
forall s. s -> Token s
Important String
"(" Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: Bool -> [Token String] -> [Token String]
go Bool
True [Token String]
ts
        go Bool
True (Important String
"+":[Token String]
ts) = ShowS
-> ([Token String] -> [Token String])
-> [Token String]
-> [Token String]
onFirstImportant (Char
'+'Char -> ShowS
forall a. a -> [a] -> [a]
:) (Bool -> [Token String] -> [Token String]
go Bool
False) [Token String]
ts
        go Bool
True (Important String
"-":[Token String]
ts) = ShowS
-> ([Token String] -> [Token String])
-> [Token String]
-> [Token String]
onFirstImportant (Char
'-'Char -> ShowS
forall a. a -> [a] -> [a]
:) (Bool -> [Token String] -> [Token String]
go Bool
False) [Token String]
ts
        go Bool
_ (Important String
t:[Token String]
ts) = let isOp :: Bool
isOp = Bool
-> (Either BinOp UnaryOp -> Bool)
-> Maybe (Either BinOp UnaryOp)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Either BinOp UnaryOp -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe (Either BinOp UnaryOp) -> Bool)
-> Maybe (Either BinOp UnaryOp) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Either BinOp UnaryOp)
parseOp String
t
                                in String -> Token String
forall s. s -> Token s
Important String
t Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: Bool -> [Token String] -> [Token String]
go Bool
isOp [Token String]
ts
        go Bool
_ (o :: Token String
o@(Other String
_):[Token String]
ts) = Token String
o Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: Bool -> [Token String] -> [Token String]
go Bool
False [Token String]
ts

-- | Re-combine multiple-character operators.
fixBinaryOps :: [Token String] -> [Token String]
fixBinaryOps :: [Token String] -> [Token String]
fixBinaryOps [] = []
fixBinaryOps (h :: Token String
h@(Important String
t1) : ts :: [Token String]
ts@(Important String
t2 : [Token String]
ts')) =
  case String -> Maybe BinOp
parseBinOp (String
t1String -> ShowS
forall a. [a] -> [a] -> [a]
++String
t2) of
    Just BinOp
o -> String -> Token String
forall s. s -> Token s
Important (BinOp -> String
renderBinOp BinOp
o) Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: [Token String] -> [Token String]
fixBinaryOps [Token String]
ts'
    Maybe BinOp
Nothing -> Token String
h Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: [Token String] -> [Token String]
fixBinaryOps [Token String]
ts
fixBinaryOps (Token String
t:[Token String]
ts) = Token String
t Token String -> [Token String] -> [Token String]
forall a. a -> [a] -> [a]
: [Token String] -> [Token String]
fixBinaryOps [Token String]
ts

renderBinOp :: BinOp -> String
renderBinOp :: BinOp -> String
renderBinOp BinOp
Add = String
"+"
renderBinOp BinOp
Sub = String
"-"
renderBinOp BinOp
Mul = String
"*"
renderBinOp BinOp
Div = String
"/"
renderBinOp BinOp
Mod = String
"%"
renderBinOp BinOp
BitAnd = String
"&"
renderBinOp BinOp
BitOr = String
"|"
renderBinOp BinOp
BitXor = String
"^"
renderBinOp BinOp
ShiftL = String
"<<"
renderBinOp BinOp
ShiftR = String
">>"
renderBinOp BinOp
LessThan = String
"<"
renderBinOp BinOp
GreaterThan = String
">"
renderBinOp BinOp
EqualTo = String
"=="
renderBinOp BinOp
NotEqualTo = String
"!="
renderBinOp BinOp
GreaterOrEqualTo = String
">="
renderBinOp BinOp
LessOrEqualTo = String
"<="
renderBinOp BinOp
And = String
"&&"
renderBinOp BinOp
Or = String
"||"

renderUnaryOp :: UnaryOp -> String
renderUnaryOp :: UnaryOp -> String
renderUnaryOp UnaryOp
Neg = String
"-"
renderUnaryOp UnaryOp
BitNot = String
"~"
renderUnaryOp UnaryOp
Not = String
"!"
renderUnaryOp UnaryOp
Defined = String
"defined "

lexExpr :: [Token String] -> Maybe [String]
lexExpr :: [Token String] -> Maybe [String]
lexExpr = [Token String] -> Maybe [String]
fixStringLits ([Token String] -> Maybe [String])
-> ([Token String] -> [Token String])
-> [Token String]
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token String] -> [Token String]
fixUnaryOps ([Token String] -> [Token String])
-> ([Token String] -> [Token String])
-> [Token String]
-> [Token String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token String] -> [Token String]
fixBinaryOps

-- * Parsing Tokens

parseUnaryOp :: String -> Maybe UnaryOp
parseUnaryOp :: String -> Maybe UnaryOp
parseUnaryOp String
"-" = UnaryOp -> Maybe UnaryOp
forall a. a -> Maybe a
Just UnaryOp
Neg
parseUnaryOp String
"~" = UnaryOp -> Maybe UnaryOp
forall a. a -> Maybe a
Just UnaryOp
BitNot
parseUnaryOp String
"!" = UnaryOp -> Maybe UnaryOp
forall a. a -> Maybe a
Just UnaryOp
Not
parseUnaryOp String
"defined" = UnaryOp -> Maybe UnaryOp
forall a. a -> Maybe a
Just UnaryOp
Defined
parseUnaryOp String
_ = Maybe UnaryOp
forall a. Maybe a
Nothing

parseBinOp :: String -> Maybe BinOp
parseBinOp :: String -> Maybe BinOp
parseBinOp String
"+" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
Add
parseBinOp String
"-" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
Sub
parseBinOp String
"*" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
Mul
parseBinOp String
"/" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
Div
parseBinOp String
"%" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
Mod
parseBinOp String
"&" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
BitAnd
parseBinOp String
"|" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
BitOr
parseBinOp String
"^" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
BitXor
parseBinOp String
"<<" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
ShiftL
parseBinOp String
">>" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
ShiftR
parseBinOp String
"<" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
LessThan
parseBinOp String
">" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
GreaterThan
parseBinOp String
"==" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
EqualTo
parseBinOp String
"!=" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
NotEqualTo
parseBinOp String
">=" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
GreaterOrEqualTo
parseBinOp String
"<=" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
LessOrEqualTo
parseBinOp String
"&&" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
And
parseBinOp String
"||" = BinOp -> Maybe BinOp
forall a. a -> Maybe a
Just BinOp
Or
parseBinOp String
_ = Maybe BinOp
forall a. Maybe a
Nothing

parseOp :: String -> Maybe (Either BinOp UnaryOp)
parseOp :: String -> Maybe (Either BinOp UnaryOp)
parseOp String
s = BinOp -> Either BinOp UnaryOp
forall a b. a -> Either a b
Left (BinOp -> Either BinOp UnaryOp)
-> Maybe BinOp -> Maybe (Either BinOp UnaryOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe BinOp
parseBinOp String
s Maybe (Either BinOp UnaryOp)
-> Maybe (Either BinOp UnaryOp) -> Maybe (Either BinOp UnaryOp)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UnaryOp -> Either BinOp UnaryOp
forall a b. b -> Either a b
Right (UnaryOp -> Either BinOp UnaryOp)
-> Maybe UnaryOp -> Maybe (Either BinOp UnaryOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe UnaryOp
parseUnaryOp String
s

readWideChar :: String -> Maybe Char
readWideChar :: String -> Maybe Char
readWideChar (Char
'L':Char
'\'':String
cs0) = Int -> String -> Maybe Char
forall a. Enum a => Int -> String -> Maybe a
go Int
0 String
cs0
  where go :: Int -> String -> Maybe a
go Int
n [Char
'\''] = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall a. Enum a => Int -> a
toEnum Int
n
        go Int
n (Char
c:String
cs) = Int -> String -> Maybe a
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) String
cs
        go Int
_ [] = Maybe a
forall a. Maybe a
Nothing
readWideChar String
_ = Maybe Char
forall a. Maybe a
Nothing

readNarrowChar :: String -> Maybe Char
readNarrowChar :: String -> Maybe Char
readNarrowChar [Char
'\'',Char
c,Char
'\''] = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
readNarrowChar String
_ = Maybe Char
forall a. Maybe a
Nothing

parseLit :: String -> Maybe Lit
parseLit :: String -> Maybe Lit
parseLit String
s = case String -> Maybe CppInt
readLitInt String
s of
               Just (CppInt Either Word Int
i) -> Lit -> Maybe Lit
forall a. a -> Maybe a
Just ((Word -> Lit) -> (Int -> Lit) -> Either Word Int -> Lit
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Word -> Lit
LitUInt Int -> Lit
LitInt Either Word Int
i)
               Maybe CppInt
Nothing -> case String -> Maybe Char
readNarrowChar String
s Maybe Char -> Maybe Char -> Maybe Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe Char
readWideChar String
s  of
                            Just Char
c -> Lit -> Maybe Lit
forall a. a -> Maybe a
Just (Char -> Lit
LitChar Char
c)
                            Maybe Char
Nothing -> case String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
s of
                                         Just String
str -> Lit -> Maybe Lit
forall a. a -> Maybe a
Just (String -> Lit
LitStr String
str)
                                         Maybe String
Nothing -> Maybe Lit
forall a. Maybe a
Nothing

digitsFromBase :: Word -> [Word] -> Word
digitsFromBase :: Word -> [Word] -> Word
digitsFromBase Word
base = (Word -> Word -> Word) -> Word -> [Word] -> Word
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word -> Word -> Word
aux Word
0
  where aux :: Word -> Word -> Word
aux Word
acc Word
d = Word
baseWord -> Word -> Word
forall a. Num a => a -> a -> a
*Word
acc Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
d

readLitInt' :: String -> Maybe Word
readLitInt' :: String -> Maybe Word
readLitInt' (Char
'0':Char
x:String
hexDigits)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' = ([Word] -> Word) -> Maybe [Word] -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word -> [Word] -> Word
digitsFromBase Word
16)
                                ((Char -> Maybe Word) -> String -> Maybe [Word]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int -> Word) -> Maybe Int -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Int -> Maybe Word)
-> (Char -> Maybe Int) -> Char -> Maybe Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe Int
hexDigit) String
hexDigits)
  where hexDigit :: Char -> Maybe Int
hexDigit Char
c
          | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
c
          | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
          | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
          | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

readLitInt' (Char
'0':String
octalDigits) = ([Word] -> Word) -> Maybe [Word] -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word -> [Word] -> Word
digitsFromBase Word
8)
                                     ((Char -> Maybe Word) -> String -> Maybe [Word]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Maybe Word
forall a. Num a => Char -> Maybe a
octalDigit String
octalDigits)
  where octalDigit :: Char -> Maybe a
octalDigit Char
c
          | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'8' = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (Int -> a) -> Int -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Maybe a) -> Int -> Maybe a
forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
c
          | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
readLitInt' String
s = String -> Maybe Word
forall a. Read a => String -> Maybe a
readMaybe String
s

-- | Read a literal integer. These may be decimal, octal, or
-- hexadecimal, and may have a case-insensitive suffix of @u@, @l@, or
-- @ul@.
readLitInt :: String -> Maybe CppInt
readLitInt :: String -> Maybe CppInt
readLitInt String
s = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
s of
                 String
"lu" -> (Word -> CppInt) -> Maybe Word -> Maybe CppInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt)
-> (Word -> Either Word Int) -> Word -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Either Word Int
forall a b. a -> Either a b
Left) (String -> Maybe Word
readLitInt' (ShowS
forall a. [a] -> [a]
init (ShowS
forall a. [a] -> [a]
init String
s)))
                 Char
'l':String
_ -> String -> Maybe CppInt
readLitInt (ShowS
forall a. [a] -> [a]
init String
s)
                 Char
'u':String
_ -> (CppInt -> CppInt) -> Maybe CppInt -> Maybe CppInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt)
-> (CppInt -> Either Word Int) -> CppInt -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Either Word Int
forall a b. a -> Either a b
Left (Word -> Either Word Int)
-> (CppInt -> Word) -> CppInt -> Either Word Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CppInt -> Word
asWord) (String -> Maybe CppInt
readLitInt (ShowS
forall a. [a] -> [a]
init String
s))
                 String
_ -> (Word -> CppInt) -> Maybe Word -> Maybe CppInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt)
-> (Word -> Either Word Int) -> Word -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either Word Int
forall a b. b -> Either a b
Right (Int -> Either Word Int)
-> (Word -> Int) -> Word -> Either Word Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (String -> Maybe Word
readLitInt' String
s)
  where asWord :: CppInt -> Word
asWord = (Word -> Word) -> (Int -> Word) -> Either Word Int -> Word
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Word -> Word
forall a. a -> a
id Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Either Word Int -> Word)
-> (CppInt -> Either Word Int) -> CppInt -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CppInt -> Either Word Int
getCppInt

-- * Shunting Yard

-- | For <https://en.wikipedia.org/wiki/Shunting-yard_algorithm reference>

data FunLike = FunBin BinOp | FunUnary UnaryOp | FunParen deriving (FunLike -> FunLike -> Bool
(FunLike -> FunLike -> Bool)
-> (FunLike -> FunLike -> Bool) -> Eq FunLike
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunLike -> FunLike -> Bool
$c/= :: FunLike -> FunLike -> Bool
== :: FunLike -> FunLike -> Bool
$c== :: FunLike -> FunLike -> Bool
Eq,Eq FunLike
Eq FunLike
-> (FunLike -> FunLike -> Ordering)
-> (FunLike -> FunLike -> Bool)
-> (FunLike -> FunLike -> Bool)
-> (FunLike -> FunLike -> Bool)
-> (FunLike -> FunLike -> Bool)
-> (FunLike -> FunLike -> FunLike)
-> (FunLike -> FunLike -> FunLike)
-> Ord FunLike
FunLike -> FunLike -> Bool
FunLike -> FunLike -> Ordering
FunLike -> FunLike -> FunLike
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FunLike -> FunLike -> FunLike
$cmin :: FunLike -> FunLike -> FunLike
max :: FunLike -> FunLike -> FunLike
$cmax :: FunLike -> FunLike -> FunLike
>= :: FunLike -> FunLike -> Bool
$c>= :: FunLike -> FunLike -> Bool
> :: FunLike -> FunLike -> Bool
$c> :: FunLike -> FunLike -> Bool
<= :: FunLike -> FunLike -> Bool
$c<= :: FunLike -> FunLike -> Bool
< :: FunLike -> FunLike -> Bool
$c< :: FunLike -> FunLike -> Bool
compare :: FunLike -> FunLike -> Ordering
$ccompare :: FunLike -> FunLike -> Ordering
$cp1Ord :: Eq FunLike
Ord,Int -> FunLike -> ShowS
[FunLike] -> ShowS
FunLike -> String
(Int -> FunLike -> ShowS)
-> (FunLike -> String) -> ([FunLike] -> ShowS) -> Show FunLike
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FunLike] -> ShowS
$cshowList :: [FunLike] -> ShowS
show :: FunLike -> String
$cshow :: FunLike -> String
showsPrec :: Int -> FunLike -> ShowS
$cshowsPrec :: Int -> FunLike -> ShowS
Show)

-- | Exhaust the function/operator stack returning the parsed
-- expression in RPN.
finishShunting :: [Parsed] -> [FunLike] -> Maybe [Parsed]
finishShunting :: [Parsed] -> [FunLike] -> Maybe [Parsed]
finishShunting [Parsed]
q [] = [Parsed] -> Maybe [Parsed]
forall a. a -> Maybe a
Just ([Parsed] -> [Parsed]
forall a. [a] -> [a]
reverse [Parsed]
q)
finishShunting [Parsed]
_ (FunLike
FunParen:[FunLike]
_) = Maybe [Parsed]
forall a. Maybe a
Nothing
finishShunting [Parsed]
q (FunBin BinOp
op:[FunLike]
ops) = [Parsed] -> [FunLike] -> Maybe [Parsed]
finishShunting (BinOp -> Parsed
PBinOp BinOp
op Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
: [Parsed]
q) [FunLike]
ops
finishShunting [Parsed]
q (FunUnary UnaryOp
op:[FunLike]
ops) = [Parsed] -> [FunLike] -> Maybe [Parsed]
finishShunting (UnaryOp -> Parsed
PUnaryOp UnaryOp
op Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
: [Parsed]
q) [FunLike]
ops

opParsed :: Either BinOp UnaryOp -> Parsed
opParsed :: Either BinOp UnaryOp -> Parsed
opParsed (Left BinOp
x) = BinOp -> Parsed
PBinOp BinOp
x
opParsed (Right UnaryOp
x) = UnaryOp -> Parsed
PUnaryOp UnaryOp
x

opFun :: Either BinOp UnaryOp -> FunLike
opFun :: Either BinOp UnaryOp -> FunLike
opFun = (BinOp -> FunLike)
-> (UnaryOp -> FunLike) -> Either BinOp UnaryOp -> FunLike
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either BinOp -> FunLike
FunBin UnaryOp -> FunLike
FunUnary

-- | Shunting yard algorithm part for dealing with operators.
juggleBinOps :: Either BinOp UnaryOp -> [Parsed] -> [FunLike]
             -> ([Parsed] -> [FunLike] -> r)
             -> r
juggleBinOps :: Either BinOp UnaryOp
-> [Parsed] -> [FunLike] -> ([Parsed] -> [FunLike] -> r) -> r
juggleBinOps Either BinOp UnaryOp
o [Parsed]
q [] [Parsed] -> [FunLike] -> r
k = [Parsed] -> [FunLike] -> r
k [Parsed]
q [Either BinOp UnaryOp -> FunLike
opFun Either BinOp UnaryOp
o]
juggleBinOps Either BinOp UnaryOp
o1 [Parsed]
q s :: [FunLike]
s@(FunLike
o2:[FunLike]
ss) [Parsed] -> [FunLike] -> r
k =
  case FunLike
o2 of
    FunBin BinOp
o -> Either BinOp UnaryOp -> r
aux (Either BinOp UnaryOp -> r) -> Either BinOp UnaryOp -> r
forall a b. (a -> b) -> a -> b
$ BinOp -> Either BinOp UnaryOp
forall a b. a -> Either a b
Left BinOp
o
    FunUnary UnaryOp
o -> Either BinOp UnaryOp -> r
aux (Either BinOp UnaryOp -> r) -> Either BinOp UnaryOp -> r
forall a b. (a -> b) -> a -> b
$ UnaryOp -> Either BinOp UnaryOp
forall a b. b -> Either a b
Right UnaryOp
o
    FunLike
FunParen -> r
done
  where a1 :: Assoc
a1 = Either BinOp UnaryOp -> Assoc
associativity Either BinOp UnaryOp
o1
        p1 :: Int
p1 = Either BinOp UnaryOp -> Int
precedence Either BinOp UnaryOp
o1
        aux :: Either BinOp UnaryOp -> r
aux Either BinOp UnaryOp
o2'
          | Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
== Assoc
LeftRight Bool -> Bool -> Bool
&& Int
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
p2 = Either BinOp UnaryOp
-> [Parsed] -> [FunLike] -> ([Parsed] -> [FunLike] -> r) -> r
forall r.
Either BinOp UnaryOp
-> [Parsed] -> [FunLike] -> ([Parsed] -> [FunLike] -> r) -> r
juggleBinOps Either BinOp UnaryOp
o1 (Either BinOp UnaryOp -> Parsed
opParsed Either BinOp UnaryOp
o2'Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
:[Parsed]
q) [FunLike]
ss [Parsed] -> [FunLike] -> r
k
          | Assoc
a1 Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
== Assoc
RightLeft Bool -> Bool -> Bool
&& Int
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
p2 = Either BinOp UnaryOp
-> [Parsed] -> [FunLike] -> ([Parsed] -> [FunLike] -> r) -> r
forall r.
Either BinOp UnaryOp
-> [Parsed] -> [FunLike] -> ([Parsed] -> [FunLike] -> r) -> r
juggleBinOps Either BinOp UnaryOp
o1 (Either BinOp UnaryOp -> Parsed
opParsed Either BinOp UnaryOp
o2'Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
:[Parsed]
q) [FunLike]
ss [Parsed] -> [FunLike] -> r
k
          | Bool
otherwise = r
done
          where p2 :: Int
p2 = Either BinOp UnaryOp -> Int
precedence Either BinOp UnaryOp
o2'
        done :: r
done = [Parsed] -> [FunLike] -> r
k [Parsed]
q (Either BinOp UnaryOp -> FunLike
opFun Either BinOp UnaryOp
o1 FunLike -> [FunLike] -> [FunLike]
forall a. a -> [a] -> [a]
: [FunLike]
s)

-- | Shunting yard to produce a reverse polish notation (RPN) list of
-- tokens.
shuntRPN :: [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN :: [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q [FunLike]
s [] = [Parsed] -> [FunLike] -> Maybe [Parsed]
finishShunting [Parsed]
q [FunLike]
s
shuntRPN [Parsed]
q [FunLike]
s (String
"(":[String]
es) = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q (FunLike
FunParenFunLike -> [FunLike] -> [FunLike]
forall a. a -> [a] -> [a]
:[FunLike]
s) [String]
es
shuntRPN [Parsed]
q [FunLike]
s (String
")":[String]
es) = let go :: [Parsed] -> [FunLike] -> Maybe [Parsed]
go [Parsed]
_ [] = Maybe [Parsed]
forall a. Maybe a
Nothing
                            go [Parsed]
q' (FunLike
FunParen:[FunLike]
s') = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q' [FunLike]
s' [String]
es
                            go [Parsed]
q' (FunBin BinOp
op:[FunLike]
s') = [Parsed] -> [FunLike] -> Maybe [Parsed]
go (BinOp -> Parsed
PBinOp BinOp
op Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
: [Parsed]
q') [FunLike]
s'
                            go [Parsed]
q' (FunUnary UnaryOp
op:[FunLike]
s') = [Parsed] -> [FunLike] -> Maybe [Parsed]
go (UnaryOp -> Parsed
PUnaryOp UnaryOp
op Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
: [Parsed]
q') [FunLike]
s'
                        in [Parsed] -> [FunLike] -> Maybe [Parsed]
go [Parsed]
q [FunLike]
s
shuntRPN [Parsed]
q [FunLike]
s ((Char
'+':e :: String
e@(Char
_:String
_)):[String]
es) = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q [FunLike]
s (String
eString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
es)
shuntRPN [Parsed]
q [FunLike]
s ((Char
'-':e :: String
e@(Char
_:String
_)):[String]
es) = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q (UnaryOp -> FunLike
FunUnary UnaryOp
Neg FunLike -> [FunLike] -> [FunLike]
forall a. a -> [a] -> [a]
: [FunLike]
s) (String
eString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
es)
shuntRPN [Parsed]
q [FunLike]
s (String
"!":[String]
es) = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q (UnaryOp -> FunLike
FunUnary UnaryOp
Not FunLike -> [FunLike] -> [FunLike]
forall a. a -> [a] -> [a]
: [FunLike]
s) [String]
es
shuntRPN [Parsed]
q [FunLike]
s (String
"~":[String]
es) = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q (UnaryOp -> FunLike
FunUnary UnaryOp
BitNot FunLike -> [FunLike] -> [FunLike]
forall a. a -> [a] -> [a]
: [FunLike]
s) [String]
es
shuntRPN [Parsed]
q [FunLike]
s (String
"defined":[String]
es) = [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q (UnaryOp -> FunLike
FunUnary UnaryOp
Defined FunLike -> [FunLike] -> [FunLike]
forall a. a -> [a] -> [a]
: [FunLike]
s) [String]
es
shuntRPN [Parsed]
q [FunLike]
s (String
e:[String]
es) =
  case String -> Maybe Lit
parseLit String
e of
    Just Lit
l -> [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN (Lit -> Parsed
PLit Lit
l Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
: [Parsed]
q) [FunLike]
s [String]
es
    Maybe Lit
Nothing -> case String -> Maybe (Either BinOp UnaryOp)
parseOp String
e of
                 Just Either BinOp UnaryOp
o -> Either BinOp UnaryOp
-> [Parsed]
-> [FunLike]
-> ([Parsed] -> [FunLike] -> Maybe [Parsed])
-> Maybe [Parsed]
forall r.
Either BinOp UnaryOp
-> [Parsed] -> [FunLike] -> ([Parsed] -> [FunLike] -> r) -> r
juggleBinOps Either BinOp UnaryOp
o [Parsed]
q [FunLike]
s (([Parsed] -> [FunLike] -> Maybe [Parsed]) -> Maybe [Parsed])
-> ([Parsed] -> [FunLike] -> Maybe [Parsed]) -> Maybe [Parsed]
forall a b. (a -> b) -> a -> b
$
                           \[Parsed]
q' [FunLike]
s' -> [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [Parsed]
q' [FunLike]
s' [String]
es
                 Maybe (Either BinOp UnaryOp)
Nothing -> [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN (Lit -> Parsed
PLit (String -> Lit
LitID String
e) Parsed -> [Parsed] -> [Parsed]
forall a. a -> [a] -> [a]
: [Parsed]
q) [FunLike]
s [String]
es

-- * Expressions

-- | Expressions are literal values, binary operators applied to two
-- sub-expressions, or unary operators applied to a single
-- sub-expression.
data Expr = ELit Lit | EBinOp BinOp Expr Expr | EUnaryOp UnaryOp Expr
            deriving (Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq, Eq Expr
Eq Expr
-> (Expr -> Expr -> Ordering)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Expr)
-> (Expr -> Expr -> Expr)
-> Ord Expr
Expr -> Expr -> Bool
Expr -> Expr -> Ordering
Expr -> Expr -> Expr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Expr -> Expr -> Expr
$cmin :: Expr -> Expr -> Expr
max :: Expr -> Expr -> Expr
$cmax :: Expr -> Expr -> Expr
>= :: Expr -> Expr -> Bool
$c>= :: Expr -> Expr -> Bool
> :: Expr -> Expr -> Bool
$c> :: Expr -> Expr -> Bool
<= :: Expr -> Expr -> Bool
$c<= :: Expr -> Expr -> Bool
< :: Expr -> Expr -> Bool
$c< :: Expr -> Expr -> Bool
compare :: Expr -> Expr -> Ordering
$ccompare :: Expr -> Expr -> Ordering
$cp1Ord :: Eq Expr
Ord, Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show)

-- | Convert an RPN list of parsed tokens into an 'Expr'.
rpnToExpr :: [Expr] -> [Parsed] -> Maybe Expr
rpnToExpr :: [Expr] -> [Parsed] -> Maybe Expr
rpnToExpr [Expr
e] [] = Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e
rpnToExpr [Expr]
_ [] = Maybe Expr
forall a. Maybe a
Nothing
rpnToExpr [Expr]
s (PLit Lit
e:[Parsed]
es) = [Expr] -> [Parsed] -> Maybe Expr
rpnToExpr (Lit -> Expr
ELit Lit
eExpr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:[Expr]
s) [Parsed]
es
rpnToExpr (Expr
s:[Expr]
ss) (PUnaryOp UnaryOp
o : [Parsed]
es) = [Expr] -> [Parsed] -> Maybe Expr
rpnToExpr (UnaryOp -> Expr -> Expr
EUnaryOp UnaryOp
o Expr
sExpr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:[Expr]
ss) [Parsed]
es
rpnToExpr (Expr
s1:Expr
s2:[Expr]
ss) (PBinOp BinOp
o : [Parsed]
es) = [Expr] -> [Parsed] -> Maybe Expr
rpnToExpr (BinOp -> Expr -> Expr -> Expr
EBinOp BinOp
o Expr
s2 Expr
s1 Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr]
ss) [Parsed]
es
rpnToExpr [Expr]
_ [Parsed]
_ = Maybe Expr
forall a. Maybe a
Nothing

-- | Try to read an 'Expr' from a sequence of 'Token's.
parseExpr :: [Token String] -> Maybe Expr
parseExpr :: [Token String] -> Maybe Expr
parseExpr = [Token String] -> Maybe [String]
lexExpr ([Token String] -> Maybe [String])
-> ([String] -> Maybe Expr) -> [Token String] -> Maybe Expr
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Parsed] -> [FunLike] -> [String] -> Maybe [Parsed]
shuntRPN [] [] ([String] -> Maybe [Parsed])
-> ([Parsed] -> Maybe Expr) -> [String] -> Maybe Expr
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Expr] -> [Parsed] -> Maybe Expr
rpnToExpr []

-- | Pretty-print an 'Expr' to something semantically equivalent to the original
-- C syntax (some parentheses may be added).
renderExpr :: Expr -> String
renderExpr :: Expr -> String
renderExpr (ELit (LitInt Int
e)) = Int -> String
forall a. Show a => a -> String
show Int
e
renderExpr (ELit (LitUInt Word
e)) = Word -> String
forall a. Show a => a -> String
show Word
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"U"
renderExpr (ELit (LitStr String
e)) = Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
eString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\""
renderExpr (ELit (LitChar Char
c)) = [Char
c]
renderExpr (ELit (LitID String
e)) = String
e
renderExpr (EBinOp BinOp
o Expr
e1 Expr
e2) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"(", Expr -> String
renderExpr Expr
e1,String
" ",BinOp -> String
renderBinOp BinOp
o
                                     , String
" ", Expr -> String
renderExpr Expr
e2, String
")" ]
renderExpr (EUnaryOp UnaryOp
o Expr
e1) = UnaryOp -> String
renderUnaryOp UnaryOp
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
renderExpr Expr
e1

-- * Evaluation

-- | All 'Expr's can be evaluated to an 'Int'.
evalExpr :: Expr -> Int
evalExpr :: Expr -> Int
evalExpr = (Word -> Int) -> (Int -> Int) -> Either Word Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int -> Int
forall a. a -> a
id (Either Word Int -> Int)
-> (Expr -> Either Word Int) -> Expr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CppInt -> Either Word Int
getCppInt (CppInt -> Either Word Int)
-> (Expr -> CppInt) -> Expr -> Either Word Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> CppInt
evalExpr'

-- | @evalExpr isDefined e@ evaluates expression @e@ in an environment
-- where the existence of macro definitions is captured by the
-- @isDefined@ predicate. All expressions evaluate to an 'Int'!
evalExpr' :: Expr -> CppInt
evalExpr' :: Expr -> CppInt
evalExpr' = Expr -> CppInt
go
  where int :: Int -> CppInt
int = Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt)
-> (Int -> Either Word Int) -> Int -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either Word Int
forall a b. b -> Either a b
Right
        word :: Word -> CppInt
word = Either Word Int -> CppInt
CppInt (Either Word Int -> CppInt)
-> (Word -> Either Word Int) -> Word -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Either Word Int
forall a b. a -> Either a b
Left
        asInt :: CppInt -> Int
asInt = (Word -> Int) -> (Int -> Int) -> Either Word Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int -> Int
forall a. a -> a
id (Either Word Int -> Int)
-> (CppInt -> Either Word Int) -> CppInt -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CppInt -> Either Word Int
getCppInt
        go :: Expr -> CppInt
go (ELit (LitInt Int
e)) = Int -> CppInt
int Int
e
        go (ELit (LitUInt Word
e)) = Word -> CppInt
word Word
e
        go (ELit (LitStr String
_)) = Int -> CppInt
int Int
1
        go (ELit (LitID String
_)) = Int -> CppInt
int Int
0
        go (ELit (LitChar Char
c)) = Int -> CppInt
int (Int -> CppInt) -> Int -> CppInt
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c
        go (EBinOp BinOp
Add Expr
e2 Expr
e3) = Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> CppInt
forall a. Num a => a -> a -> a
+ Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
Sub Expr
e2 Expr
e3) = Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> CppInt
forall a. Num a => a -> a -> a
- Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
Mul Expr
e2 Expr
e3) = Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> CppInt
forall a. Num a => a -> a -> a
* Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
Div Expr
e2 Expr
e3) = (forall a. Integral a => a -> a -> a) -> CppInt -> CppInt -> CppInt
integralCpp forall a. Integral a => a -> a -> a
div (Expr -> CppInt
go Expr
e2) (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
Mod Expr
e2 Expr
e3) = (forall a. Integral a => a -> a -> a) -> CppInt -> CppInt -> CppInt
integralCpp forall a. Integral a => a -> a -> a
mod (Expr -> CppInt
go Expr
e2) (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
BitAnd Expr
e2 Expr
e3) = (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt
bitsCpp forall a. Bits a => a -> a -> a
(.&.) (Expr -> CppInt
go Expr
e2) (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
BitOr Expr
e2 Expr
e3) = (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt
bitsCpp forall a. Bits a => a -> a -> a
(.|.) (Expr -> CppInt
go Expr
e2) (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
BitXor Expr
e2 Expr
e3) = (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt
bitsCpp forall a. Bits a => a -> a -> a
xor (Expr -> CppInt
go Expr
e2) (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
ShiftL Expr
e2 Expr
e3) = Expr -> CppInt
go Expr
e2 CppInt -> Int -> CppInt
`cppShiftL` CppInt -> Int
asInt (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
ShiftR Expr
e2 Expr
e3) = Expr -> CppInt
go Expr
e2 CppInt -> Int -> CppInt
`cppShiftR` CppInt -> Int
asInt (Expr -> CppInt
go Expr
e3)
        go (EBinOp BinOp
LessThan Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Ord a => a -> a -> Bool
< Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
GreaterThan Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Ord a => a -> a -> Bool
> Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
EqualTo Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
== Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
NotEqualTo Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
/= Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
GreaterOrEqualTo Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Ord a => a -> a -> Bool
>= Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
LessOrEqualTo Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Ord a => a -> a -> Bool
<= Expr -> CppInt
go Expr
e3
        go (EBinOp BinOp
And Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CppInt
0 Bool -> Bool -> Bool
&& Expr -> CppInt
go Expr
e3 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CppInt
0
        go (EBinOp BinOp
Or Expr
e2 Expr
e3) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CppInt
0 Bool -> Bool -> Bool
|| Expr -> CppInt
go Expr
e3 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CppInt
0
        go (EUnaryOp UnaryOp
Neg Expr
e2) = CppInt -> CppInt
forall a. Num a => a -> a
negate (Expr -> CppInt
go Expr
e2)
        go (EUnaryOp UnaryOp
BitNot Expr
e2) = CppInt -> CppInt
cppComplement (CppInt -> CppInt) -> CppInt -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2
        go (EUnaryOp UnaryOp
Not Expr
e2) = Int -> CppInt
int (Int -> CppInt) -> (Bool -> Int) -> Bool -> CppInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> CppInt) -> Bool -> CppInt
forall a b. (a -> b) -> a -> b
$ Expr -> CppInt
go Expr
e2 CppInt -> CppInt -> Bool
forall a. Eq a => a -> a -> Bool
== CppInt
0
        go (EUnaryOp UnaryOp
Defined Expr
e2) =
          case Expr
e2 of
            ELit (LitInt Int
1) -> CppInt
1
            Expr
_ -> CppInt
0