Stack code from TDD book: trying to remove code duplicates - idris

Question

Faced next problem while reading great Type Driven Development book and trying to implement some small modifications of tasks in it.
module Main
import Data.Vect
%default total
data Forever = More Forever
partial
forever : Forever
forever = More forever
data StackCmd : Type -> (inputHeight : Nat) -> (outputHeight : Nat) -> Type where
Push : Integer -> StackCmd () height (S height)
Pop : StackCmd Integer (S height) height
Top : StackCmd Integer (S height) (S height)
PutStr : String -> StackCmd () h h
PutStrLn : String -> StackCmd () h h
GetStr : StackCmd String h h
Pure : a -> StackCmd a h h
(>>=) : StackCmd a h1 h2 -> (a -> StackCmd b h2 h3) -> StackCmd b h1 h3
runStack : (stck : Vect inH Integer) -> StackCmd ty inH outH -> IO (ty, Vect outH Integer)
runStack stck (Push x) = pure ((), x :: stck)
runStack (x :: xs) Pop = pure (x, xs)
runStack (x :: xs) Top = pure (x, x :: xs)
runStack xs (PutStr str) = do putStr str; pure ((), xs)
runStack xs (PutStrLn str) = do putStrLn str; pure ((), xs)
runStack xs (GetStr) = do str <- getLine; pure (str, xs)
runStack stck (Pure x) = pure (x, stck)
runStack stck (x >>= f) = do (x', stck') <- runStack stck x
runStack stck' (f x')
data StackIO : Nat -> Type where
Do : StackCmd a h1 h2 -> (a -> Inf (StackIO h2)) -> StackIO h1
QuitCmd : (a : Nat) -> StackIO a
namespace StackDo
(>>=) : StackCmd a h1 h2 -> (a -> Inf (StackIO h2)) -> StackIO h1
(>>=) = Do
data Input : Type where
INumber : Integer -> Input
IAdd : Input
IDuplicate : Input
IDiscard : Input
parseInput : String -> Maybe Input
parseInput str =
case str of
"" => Nothing
"add" => Just IAdd
"duplicte" => Just IDuplicate
"discard" => Just IDiscard
_ => if all isDigit $ unpack str then Just (INumber $ cast str) else Nothing
run : Forever -> Vect n Integer -> StackIO n -> IO ()
run _ _ (QuitCmd a) = pure ()
run (More far) stck (Do sa f) = do (a', stck') <- runStack stck sa
run far stck' (f a')
biOp : (Integer -> Integer -> Integer) -> StackCmd String (S (S height)) (S height)
biOp op = do a <- Pop
b <- Pop
let res = a `op` b
Push res
Pure $ show res
discardUnOp : StackCmd String (S height) height
discardUnOp = do v <- Pop
Pure $ "Discarded: " ++ show v
duplicateUnOp : StackCmd String (S height) (S (S height))
duplicateUnOp = do v <- Top
Push v
Pure $ "Duplicated: " ++ show v
mutual
tryBiOp : String -> (Integer -> Integer -> Integer) -> StackIO hin
tryBiOp _ op {hin=S (S k)} = do res <- biOp op
PutStrLn res
stackCalc
tryBiOp opName _ = do PutStrLn $
"Unable to execute operation " ++ opName ++ ": fewer then two items on stack."
stackCalc
tryUnOp : Show a => String -> StackCmd a hIn hOut -> StackIO hIn
tryUnOp _ op {hIn=S h} = do res <- op
PutStrLn $ show res
stackCalc
tryUnOp opName _ = do PutStrLn $
"Unable to execute " ++ opName ++ " operation: no elements on stack."
stackCalc
stackCalc : StackIO height
stackCalc = do PutStr "> "
inp <- GetStr
case parseInput inp of
Nothing => do PutStrLn "invalid input"; stackCalc
(Just (INumber x)) => do Push x; stackCalc
(Just IAdd) => tryBiOp "add" (+)
(Just IDuplicate) => ?holedup
(Just IDiscard) => ?holedisc -- tryUnOp "discard" discardUnOp
partial
main : IO ()
main = run forever [] stackCalc
Code given above is mostly from TDD book. Sorry that its a bit long: it can be compiled. The code is rather straightforward: this is a stack implemented above vector. Then, user can type numbers in command prompt (one per line) and program pushes the numbers on stack. User is also able to call operations, i.e. add. add pops two elements from stack, adds them and pushes the result back on stack. So, add requires at least two numbers to be on stack when it is called.
Please take a look on tryBiOp function. It takes an Integer -> Integer -> Integer (i.e. (+) or (-)) operation as it's argument and returns sequence of StackCmd operations which implements needed action. As a result programmer can write (Just IAdd) => tryBiOp "add" (+) inside stackCalc. This is very close to what I would like to have.
Question. Next thing I would like to do is very the same wrapper (it named tryUnOp) for operations which require one element on stack. And since these operations are not on integers, but on a stack itself (i.e. "duplicate top of stack" or "discard top element") I would like to pass to wrapper the sequence of StackCmd operations instead of Integer -> Integer -> Integer. So, what I would like to gain is
(Just IDuplicate) => tryUnOp "duplicate" $
(do v <- Top
Push v
Pure $ "Duplicated: " ++ show v)
Problem. If you uncomment code in string (Just IDiscard) => ?holedisc -- tryUnOp "discard" discardUnOp (and remove hole), you will see that code can not be compiled. As I see problem is that when I call tryUnOp "discard" discardUnOp Idris can see that tryUnOp's hIn must be of form (S k) because it follows from discardUnOp's type. But stackCalc does not provide such guarantee.
Working solution. It works, but it is essentially the same thing for unary operation as for binary. So, it is not exactly what I would like to have. There is a function which converts name of operation to sequence of stack commands:
data UnaryOperation : Type where
UODup : UnaryOperation
UODisc : UnaryOperation
UnaryOpOutHeight : UnaryOperation -> Nat -> Nat
UnaryOpOutHeight UODup inheightBase = S (S inheightBase)
UnaryOpOutHeight UODisc inheightBase = inheightBase
unaryStackCmd : (op: UnaryOperation) -> StackCmd String (S h) (UnaryOpOutHeight op h)
unaryStackCmd UODup = duplicateUnOp
unaryStackCmd UODisc = discardUnOp
mutual
tryUnOp' : String -> UnaryOperation -> StackIO height
tryUnOp' _ op {height=S h} = do res <- unaryStackCmd op
PutStrLn res
stackCalc
tryUnOp' opName _ = do PutStrLn $
"Unable to execute " ++ opName ++ " operation: no elements on stack."
stackCalc
Any ideas / comments are wellcome!!!