A larger example: Calculator

The implementation of the desktop calculator is derived from the Fudgets example calculator:

type CalcStack = [Integer]

type CalcState = 
 (CalcStack, 
  Integer, 
  Bool,
  Bool)

numOp :: Integer -> CalcState -> CalcState
numOp n (x:xs, b, c, q) = ((if c then n:x:xs else if n < b then x*b+n:xs else x:xs), b, False,q)

unaryOp :: (Integer->Integer) -> CalcState -> CalcState
unaryOp f (x:xs, b, c, q) = (f x:xs, b, True,q)

quitCalc :: CalcState -> CalcState
quitCalc (ls, b, c, q) = (ls, b, c, True)

binaryOp :: (Integer -> Integer -> Integer) -> CalcState -> CalcState
binaryOp f ([x], b, c, q) = binaryOp f ([x,x], b, True, q)
binaryOp f (x:y:xs, b, c, q) = (f y x:xs, b, True, q)

dispCalcState :: CalcState -> String
dispCalcState (x:xs, b, _, _) = (if x < 0 then '-':bconv b (0-x) else bconv b x)++"    "++show b

startstate = ([0::Integer], 10, False, False)

digit d = ["0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"!!(d)]
bconv b x = if x < b then digit x else bconv b (x`div`b) ++ digit (x`mod`b)

button_ls :: [Component (Button (CalcState -> CalcState), DisplayHandle)]
button_ls =
 [button (text "Quit")  (quitCalc),
  button (text "Enter") (\ (x:xs, b, c, q) -> (x : x : xs, b, True, q)),
  button (text "Clear") (\ (_:xs, b, c, q) -> (0:xs, b, False, q)),
  button (text "BS")    (\ (x:xs, b, c, q) -> 
                           ((if c then x else x`div`b):xs, b, c, q)),
  button (text "D")     (numOp 13), button (text "E")     (numOp 14),
  button (text "F")     (numOp 15), button (text "mod")   (binaryOp (mod)),
  button (text "A")     (numOp 10), button (text "B")     (numOp 11),
  button (text "C")     (numOp 12), button (text "/")     (binaryOp (div)),
  button (text "7")     (numOp 7),  button (text "8")     (numOp 8),
  button (text "9")     (numOp 9),  button (text "*")     (binaryOp (*)),
  button (text "4")     (numOp 4),  button (text "5")     (numOp 5),
  button (text "6")     (numOp 6),  button (text "-")     (binaryOp (-)),
  button (text "1")     (numOp 1),  button (text "2")     (numOp 2),
  button (text "3")     (numOp 3),  button (text "+")     (binaryOp (+)),
  button (text "0")     (numOp 0),  button (text "Chs")   (unaryOp (0-)),
  button (text "Base")  (\ (x:xs, b, c, q) -> 
                           (x:xs, (if x <= 36 && x > 1 then x else b), True, q)),
  button (text "Pop")   (\ (x:xs, b, c, q) -> 
                           (if null xs then ([x],b,c, q) else (xs,b,c, q)))]

main =
 mkDC ["*title: Calc"]           >>= \ env ->
  mapIO (\ x -> x env) button_ls >>= \ ls ->
  let
   (btns, dhs) = unzip ls
   
   vs = zip
         [(x,y) | y<-[1..7],x<-[1..4]]
	 dhs
  in
  fixedTable (4,7) (2,2) vs env         >>= \ (tab, tab_dh) ->
  label "0" env                         >>= \ (lab, lab_dh) ->
  realiseDH env (vbox [lab_dh, tab_dh]) >>
  combineButtons btns                   >>= \ btn ->
  let
   loop st =
    getButtonClick btn >>= \ op ->
    case op st of
      st1@(_,val,_,quit) ->
	 if quit then
	    shutdownShop
	 else
	    setLabel lab (dispCalcState st1) >>
	    loop st1
  in
  loop startstate