{-# LANGUAGE RankNTypes #-}
module PinchApp where
import Data.Array
import System.IO
import Text.Read
import PinchDef
import Pinch
instance MonadPinchSim IO where
askPinch msg arr =
case msg of
NoMsg -> pure ()
OKMsg -> putStrLn “OK, array updated.”
BadPositionMsg -> putStrLn “Bad position, array not updated.”
>> putStrLn (“Current array: ” ++ show (elems arr))
>> readInt
>>= \i -> readDir
>>= \d -> pure (i, d)
readInt =
putStr “Please enter position to pinch: ” >> hFlush stdout
>> getLine
>>= \s -> case readMaybe s of
Nothing -> putStrLn “Sorry, need an integer” >> readInt
Just i -> pure i
readDir =
putStr “Please enter direction to pinch (up/down): ” >> hFlush stdout
>> getLine
>>= \s -> case s of
“up” -> pure Up
“down” -> pure Down
_ -> putStrLn “Sorry, need up or down” >> readDir
playIO :: (forall m. MonadPinchSim m => m a) -> IO a
playIO server = server
playTrace :: PinchTrace a -> IO a
playTrace (Pure a) = pure a
playTrace (Step msg arr next) =
case msg of
NoMsg -> pure ()
OKMsg -> putStrLn “OK, array updated.”
BadPositionMsg -> putStrLn “Bad position, array not updated.”
>> putStrLn (“Current array: ” ++ show (elems arr))
>> readInt
>>= \i -> readDir
>>= \d -> playTrace (next i d)
mytest :: (Array Int Integer -> PinchTrace a) -> Either String ()
mytest f =
case f arr0 of
Pure _ -> Left “shouldn’t be Pure”
Step msg arr next
| msg /= NoMsg -> Left “wrong msg”
| arr /= arr0 -> Left “wrong array”
| otherwise ->
case next 2 Down of
Step _ _ _ -> Left “shouldn’t be Step”
Pure _ -> Right ()
where
arr0 = listArray (1,3) [1,2,1]