monadsample.hs

import Text.Read

-- Each invocation consumes strings from a stream
-- So canonically, we apply ([String],()) yielding
-- ([String],a)
data SampleMonadValue a 
  = SMV ([String] -> Either ([String],[String]) ([String],[String],a))

sampleWrite :: String -> SampleMonadValue ()
sampleWrite s = SMV $ \strings ->
  Right ([s], strings, ())

sampleRead :: SampleMonadValue String
sampleRead = SMV $ \strings ->
  case strings of
    [] -> Left (["out of strings!"], [])
    hd  : tl -> Right ([], tl, hd)

sampleDie :: String -> SampleMonadValue a
sampleDie die = SMV $ \strings -> Left ([die],strings)

instance Functor SampleMonadValue where
  fmap f (SMV mv) =
   SMV $ \strings ->
    case mv strings of
      Left (errres, nextstrings) -> Left (errres, nextstrings)
      Right (newouts, nextstrings, nextv) -> Right (newouts, nextstrings, f nextv)

instance Applicative SampleMonadValue where
  (<*>) (SMV mf) (SMV mv) =
    SMV $ \strings ->
      case mf strings of
        Left (errres, nextstrings) -> Left (errres,nextstrings)
        Right (newouts, nextstrings, nextf) ->
          case mv nextstrings of
            Left (newerr, finalstrings) -> Left (newouts ++ newerr, finalstrings)
            Right (finalouts, finalstrings, nextv) -> Right (newouts ++ finalouts, finalstrings, nextf nextv)
  pure a = SMV $ \strings -> Right ([],strings,a)

instance Monad SampleMonadValue where
  (>>=) (SMV mv) f =
    SMV $ \strings ->
      case mv strings of
        Left (errres, nextstrings) -> Left (errres, nextstrings)
        Right (output, nextstrings, nextval) ->
          let (SMV res) = f nextval in
          case res nextstrings of
            Left (newouts,finalstrings) -> 
              Left (output ++ newouts,finalstrings)
            Right (newouts,finalstrings,finalval) ->
              Right (output ++ newouts,finalstrings,finalval)

  return = pure
  fail str = SMV $ \strings -> Left ([str],strings)

runSampleMonad :: [String] -> SampleMonadValue a -> (Either [String] a)
runSampleMonad strings (SMV mv) = do
  case mv strings of
    Left (errres, remaining) -> Left errres
    Right (output, [], val) -> Right val

runSampleMonadIO :: SampleMonadValue a -> IO (Either [String] a)
runSampleMonadIO sm = do
  content <- getContents
  pure $ runSampleMonad (lines content) sm

converse :: SampleMonadValue Int
converse = do
  sampleWrite "Welcome, type your number"
  number <- sampleRead
  case readMaybe number of
    Nothing -> sampleDie "Could not read a number!"
    Just v -> pure v

main :: IO ()
main = do
  putStrLn "Trying"
  let res1 = runSampleMonad ["hi"] converse
  putStrLn $ "result (fail): " ++ (show res1)
  let res2 = runSampleMonad ["3"] converse
  putStrLn $ "result (good): " ++ (show res2)