FlexibleContextsError.hs

{-# LANGUAGE FlexibleContexts #-}
module NetStrings where
import Data.Char (ord) 
import Control.Monad (forever)
import Control.Monad.Except
import Data.Either.Utils

netstring :: String -> Either String (String, String)
netstring xs = netstring' 0 xs -- size body
    where
        netstring' _ []          = Left "unexpected end of stream"
        netstring' c _ 
          | c > 4096             = Left "message size too large"
        netstring' c (x:xs)
          | x >= '0' && x <= '9' = netstring' (c * 10 + (ord x - ord '0')) xs
          | x /= ':'             = Left "missing colon"
          | x == ':'             = consume c (take c xs) (drop c xs)
        consume c _ []           = Left "unexpected end of stream"
        consume c msg (x:xs)
          | length msg /= c      = Left "unexpected end of stream"
          | x /= ','             = Left "missing comma"
          | x == ','             = Right (msg, xs)

netstrings :: (MonadError String m) => String -> m [String]
netstrings xs = do
    (msg, xs) <- eitherToMonadError $ netstring xs
    if null xs 
    then return [msg]
    else do 
        rest <- netstrings xs
        return (msg:rest)