Pattern matching + State monad + Monad transformers

PatternState.hs

#! /usr/bin/env cabal
{- cabal:
build-depends: base >= 4.9 && < 4.13
             , mtl ^>= 2.2.2
             , text ^>= 1.2.3
-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}

-- This gist contains code for the following blog post:
-- https://kowainik.github.io/posts/2018-11-18-state-pattern-matching

module Main where

import Control.Monad.Except (MonadError (..))
import Control.Monad.State (MonadState, StateT (..), gets, put)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)


data Value
    = BoolValue Bool
    | IntValue Int
    deriving Show

----------------------------------------------------------------------------
-- Decoding single value
----------------------------------------------------------------------------

data SingleValueError = SingleValueError
    { valueErrorExpected :: Text
    , valueErrorActual   :: Value
    } deriving Show

valToBool :: Value -> Either SingleValueError Bool
valToBool (BoolValue b) = Right b
valToBool v             = Left $ SingleValueError "Bool" v

valToInt :: Value -> Either SingleValueError Int
valToInt (IntValue i) = Right i
valToInt v            = Left $ SingleValueError "Int" v

----------------------------------------------------------------------------
-- Decoding list of values
----------------------------------------------------------------------------

data ListValueError
    = UnexpectedEndOfList
    | ExpectedEndOfList (NonEmpty Value)
    | WrongValue SingleValueError
    deriving Show

newtype Values = Values { unValues :: [Value] }
    deriving Show

newtype Decoder a = Decoder
    { runDecoder :: StateT Values (Either ListValueError) a
    } deriving (Functor, Applicative, Monad, MonadState Values, MonadError ListValueError)

value
    :: (Value -> Either SingleValueError a)
    -> Decoder a
value valDecoder = gets unValues >>= \case
    [] -> throwError UnexpectedEndOfList
    val:vals -> case valDecoder val of
        Left err -> throwError $ WrongValue err
        Right a  -> a <$ put (Values vals)

decodeValues :: [Value] -> Decoder a -> Either ListValueError a
decodeValues values decoder = do  -- do-notation for the Either monad
    (a, finalState) <- runStateT (runDecoder decoder) (Values values)
    case unValues finalState of
        []       -> pure a
        val:vals -> Left $ ExpectedEndOfList (val :| vals)

----------------------------------------------------------------------------
-- User decoder
----------------------------------------------------------------------------

data User = User
    { userAge         :: Int
    , userIsHaskeller :: Bool
    } deriving Show

user :: Decoder User
user = User <$> value valToInt <*> value valToBool

main :: IO ()
main = do
    let userDecoder values = decodeValues values user
    print $ userDecoder []
    print $ userDecoder [IntValue 42, BoolValue True]
    print $ userDecoder [BoolValue True, IntValue 42]
    print $ userDecoder [IntValue 42, BoolValue True, BoolValue False]

{- Output of the main function:

Left UnexpectedEndOfList
Right (User {userAge = 42, userIsHaskeller = True})
Left (WrongValue (SingleValueError {valueErrorExpected = "Int", valueErrorActual = BoolValue True}))
Left (ExpectedEndOfList (BoolValue False :| []))

-}