Small RPN calculator

razz_lang.hs

-- razz_lang

import Data.Function
import Data.Semigroup

import qualified Data.List as List
import qualified Data.Map as Map
import qualified Text.Read as Read

-- Stack types
data StackValue =
    VInt Int |
    VDouble Double

instance Show StackValue where
    show (VInt n) = show n
    show (VDouble n) = show n

newtype Stack = Stack { unStack :: [StackValue] }

instance Show Stack where
    show stack = "|[ "
        ++ (unStack stack & reverse & (map show) & List.intercalate "  ")

instance Semigroup Stack where
    (<>) first second = unStack first & (++ unStack second) & Stack

-- Helpers to wrap error handling
exeUna :: (StackValue -> Stack) -> Stack -> Stack 
exeUna f stack = case unStack stack of
    (item : rest) -> (f item) <> Stack rest
    [] -> error "Cannot apply function, stack is empty"

exeBin :: (StackValue -> StackValue -> Stack) -> Stack -> Stack
exeBin f stack = case unStack stack of
    (m : n : rest) -> (f n m)  <> Stack rest
    _ -> error "Cannot apply function, stack contains less than two items"

data FnType =
    Una (StackValue -> Stack) |
    Bin (StackValue -> StackValue -> Stack)

-- More helpers
tryUnaInt :: (Int -> Int) -> String -> StackValue -> StackValue
tryUnaInt f _ (VInt m) = f m & VInt
tryUnaInt _ name _ = "Cannot apply `" ++ name ++ "` because value is not of type Int" & error

tryBinInt :: (Int -> Int -> Int) -> String -> StackValue -> StackValue -> StackValue
tryBinInt f _ (VInt m) (VInt n) = f m n & VInt
tryBinInt _ name _ _ = "Cannot apply `" ++ name ++ "` because values are not of type Int" & error

tryUnaDouble :: (Double -> Double) -> String -> StackValue -> StackValue
tryUnaDouble f _ (VDouble m) = f m & VDouble
tryUnaDouble _ name _ = "Cannot apply `" ++ name ++ "` because value is not of type Double" & error

tryBinDouble :: (Double -> Double -> Double) -> String -> StackValue -> StackValue -> StackValue
tryBinDouble f _ (VDouble m) (VDouble n) = f m n & VDouble
tryBinDouble _ name _ _ = "Cannot apply `" ++ name ++ "` because values are not of type Double" & error

newUna :: String -> (String -> StackValue -> StackValue) -> (String, FnType)
newUna name f = (name, (\m -> [f name m] & Stack) & Una)

newBin :: String -> (String -> StackValue -> StackValue -> StackValue) -> (String, FnType)
newBin name f = (name, (\m n -> [f name m n] & Stack) & Bin)

-- All functions in the language
fns :: Map.Map String FnType
fns = Map.fromList [
        -- Int
        (newBin "+" $ tryBinInt (+)),
        (newBin "-" $ tryBinInt (-)),
        (newBin "*" $ tryBinInt (*)),
        -- 1/0 = 0
        (newBin "//" $ tryBinInt (\m n -> if n == 0 then 0 else m `div` n)),
        (newUna "~" $ tryUnaInt (negate)),
        
        -- Double
        (newBin "+." $ tryBinDouble (+)),
        (newBin "-." $ tryBinDouble (-)),
        (newBin "*." $ tryBinDouble (*)),
        -- 1.0/0.0 = 0
        (newBin "/." $ tryBinDouble (\m n -> if n == 0 then 0 else m / n)),
        (newUna "~." $ tryUnaDouble (negate)),
        
        -- Conversion
        ("->double",
            Una (\m -> case m of
                (VInt m) -> Stack [fromIntegral m & VDouble]
                _ -> error "Cannot convert Double to Double"
            )
        ),
        ("->int",
            Una (\m -> case m of
                (VDouble m) -> Stack [round m & VInt]
                _ -> error "Cannot convert Int to Int"
            )
        ),
        
        -- Universal
        ("swap", Bin (\m n -> Stack [n, m])),
        ("drop", Una (\_ -> Stack [])),
        ("copy", Una (\m -> Stack [m, m]))
    ]

-- Interpreter
exec :: String -> Stack
exec source = go (words source) (Stack [])
    where
        go :: [String] -> Stack -> Stack
        go [] stack = stack
        
        go (value : values) stack = case value of
            -- comments start with `(`, no spaces allowed
            ('(': _) -> go values stack
            -- Int being read before double means all numerics without a `.` are Ints 
            _ -> case (Read.readMaybe value) :: Maybe Int of
                Just m -> Stack [VInt m] <> stack & go values 
                Nothing -> case (Read.readMaybe value) :: Maybe Double of
                    Just d -> Stack [VDouble d] <> stack & go values
                    Nothing -> case Map.lookup value fns of
                        Just (Una una) -> exeUna una stack & go values
                        Just (Bin bin) -> exeBin bin stack & go values
                        Nothing -> "Unrecoginzed thingy `" ++ value ++ "`" & error

main = "2.0 1.0 -. ->int -1 + 0 * 45 copy drop swap // ->double (output=0.0)"
    & exec
    & show
    & putStrLn