Skip to content

Instantly share code, notes, and snippets.

@chshersh chshersh/PatternState.hs
Last active Jan 6, 2019

Embed
What would you like to do?
Pattern matching + State monad + Monad transformers
#! /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 :| []))
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.