StackExpr1.hs

module StackExpr where

data Instr
  = Const Integer
  | Add
  | Sub
  | Mul
  | Neg
  | Abs
  | Sig
  deriving (Show)

newtype Program = P [Instr] deriving (Show)

instance Num Program where
  fromInteger i = P [Const i]
  P a + P b = P (b ++ a ++ [Add])
  P a - P b = P (b ++ a ++ [Sub])
  P a * P b = P (b ++ a ++ [Mul])
  negate (P a) = P (a ++ [Neg])
  abs (P a) = P (a ++ [Abs])
  signum (P a) = P (a ++ [Sig])

eval :: Program -> Integer
eval (P xs) = go [] xs
  where
    go (x:_) [] = x
    go xs (Const i:ys) = go (i:xs) ys
    go (a:b:xs) (Add:ys) = go ((a+b):xs) ys
    go (a:b:xs) (Mul:ys) = go ((a*b):xs) ys
    go (a:b:xs) (Sub:ys) = go ((a-b):xs) ys
    go (a:xs) (Neg:ys) = go ((negate a):xs) ys
    go (a:xs) (Abs:ys) = go ((abs a):xs) ys
    go (a:xs) (Sig:ys) = go ((signum a):xs) ys

StackExpr2.hs

module StackExpr where

data BinOp
  = Add
  | Mul
  | Sub
  deriving (Show)

data UnaOp
  = Neg
  | Abs
  | Sig
  deriving (Show)

data Instr
  = Const Integer
  | BinOp BinOp
  | UnaOp UnaOp
  deriving (Show)

binop :: BinOp -> Integer -> Integer -> Integer
binop Add = (+)
binop Mul = (*)
binop Sub = (-)

unaop :: UnaOp -> Integer -> Integer
unaop Neg = negate
unaop Abs = abs
unaop Sig = signum

newtype Program = P [Instr] deriving (Show)

formatBin :: BinOp -> Program -> Program -> Program
formatBin op (P a) (P b) = P (b ++ a ++ [BinOp op])

formatUna :: UnaOp -> Program -> Program
formatUna op (P a) = P (a ++ [UnaOp op])

instance Num Program where
  fromInteger i = P [Const i]
  (+) = formatBin Add
  (-) = formatBin Sub
  (*) = formatBin Mul
  negate = formatUna Neg
  abs = formatUna Abs
  signum = formatUna Sig

eval :: Program -> Integer
eval (P xs) = go [] xs
  where
    go (x:_) [] = x
    go xs (Const i:ys) = go (i:xs) ys
    go (a:b:xs) (BinOp x:ys) = go ((binop x a b):xs) ys
    go (a:xs) (UnaOp x:ys) = go ((unaop x a):xs) ys

StackExpr3.hs

{-# Language ConstraintKinds #-}
{-# Language GADTs #-}
module StackExpr where

data BinOp
  = Add
  | Mul
  | Sub
  deriving (Show)

data UnaOp
  = Neg
  | Abs
  | Sig
  deriving (Show)

data Instr
  = Const Integer
  | BinOp BinOp
  | UnaOp UnaOp
  deriving (Show)

newtype Program = P [Instr] deriving (Show)

formatBin :: BinOp -> Program -> Program -> Program
formatBin op (P a) (P b) = P (b ++ a ++ [BinOp op])

formatUna :: UnaOp -> Program -> Program
formatUna op (P a) = P (a ++ [UnaOp op])

instance Num Program where
  fromInteger i = P [Const i]
  (+) = formatBin Add
  (-) = formatBin Sub
  (*) = formatBin Mul
  negate = formatUna Neg
  abs = formatUna Abs
  signum = formatUna Sig

---

{-
class Num a where
  (+) :: a -> a -> a
  (-) :: a -> a -> a
  (*) :: a -> a -> a
  negate :: a -> a
  abs :: a -> a
  signum :: a -> a
  fromInteger :: Integer -> a
-}

data DNum where
  NumAdd :: DNum -> DNum -> DNum
  NumSub :: DNum -> DNum -> DNum
  NumMul :: DNum -> DNum -> DNum
  NumNeg :: DNum -> DNum
  NumAbs :: DNum -> DNum
  NumSig :: DNum -> DNum
  NumInt :: Integer -> DNum
  deriving Show

instance Num DNum where
  (+) = NumAdd
  (-) = NumSub
  (*) = NumMul
  negate = NumNeg
  abs = NumAbs
  signum = NumSig
  fromInteger = NumInt

asNum :: Num a => DNum -> a
asNum = go
  where
    go (NumAdd a b) = go a + go b
    go (NumSub a b) = go a - go b
    go (NumMul a b) = go a * go b
    go (NumNeg a) = negate (go a)
    go (NumAbs a) = abs (go a)
    go (NumSig a) = signum (go a)
    go (NumInt i) = fromInteger i

class ToDNum a where
  toDNum :: a -> DNum

instance ToDNum DNum where
  toDNum = id

instance ToDNum Program where
  toDNum (P xs) = go [] xs
    where
      go [x] [] = x
      go xs (Const i:ys) = go (NumInt i:xs) ys
      go (a:b:xs) (BinOp op:ys) = go (bin op a b:xs) ys
      go (a:xs) (UnaOp op:ys) = go (una op a:xs) ys

      bin Add = NumAdd
      bin Sub = NumSub
      bin Mul = NumMul

      una Neg = NumNeg
      una Abs = NumAbs
      una Sig = NumSig

eval :: Program -> Integer
eval = asNum . toDNum