Suspendable Process

{-# LANGUAGE GADTs, StandaloneDeriving #-}

half x = fromIntegral x / 2 :: Rational


data Stage a where
  StageInit  :: Stage Int
  StageHalf  :: Stage Rational
  StageCalc  :: Stage Double
  StageFinal :: Stage String

deriving instance Show (Stage a)

data Suspended where
    Suspended :: Show as => Stage as -> as -> Suspended

instance Show Suspended where
  show (Suspended stage as) = show stage ++ ", " ++ show as

instance Read Suspended where
  readsPrec = const $ uncurry ($) . mapFst parse . fmap (drop 2) . break (==',')
    where
      parse :: String -> String -> [(Suspended, String)]
      parse stage = case stage of
        "StageInit"  -> parse' StageInit
        "StageHalf"  -> parse' StageHalf
        "StageCalc"  -> parse' StageCalc
        "StageFinal" -> parse' StageFinal
        _ -> const []

      parse' :: (Show as, Read as) => Stage as -> String -> [(Suspended, String)]
      parse' stg st = [(Suspended stg (read st), mempty)]

      mapFst :: (a -> c) -> (a, b) -> (c, b)
      mapFst f ~(a, b) = (f a, b)


runTAListStep :: Suspended -> Suspended
runTAListStep (Suspended StageInit r) = Suspended StageHalf (half r)
runTAListStep (Suspended StageHalf r) = Suspended StageCalc (fromRational r)
runTAListStep (Suspended StageCalc r) = Suspended StageFinal (show r)

main = do
  let s1 = show $ runTAListStep $ read "StageInit, 5"
  putStrLn s1
  let s2 = show $ runTAListStep $ read s1
  putStrLn s2
  let s3 = show $ runTAListStep $ read s2
  putStrLn s3