Unification of Result and Operation

validate.hs

#!/usr/bin/env stack
{- stack
 exec ghci
 --resolver lts-17.9
-}

{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeApplications           #-}

main
  :: IO ()
main = do
  putStrLn
    "We DO NOT get accumulating errors for Result because its applicative instance throws away data [1]:"
  print $ validateResult $ RawData Nothing Nothing Nothing
  nl

  putStrLn
    "We DO get accumulating errors for Operation because its applicative instance does not throw away data:"
  print $ validateOperation $ RawData Nothing Nothing Nothing
  nl

  putStrLn $ unlines
    [ "The only difference between 'Result' and 'Operation' are their 'Applicative' instances."
    , "We can unify 'Result' and 'Operation' under a new typeclass."
    ]
  print $ validate @(Result [CustomError]) $ RawData Nothing Nothing Nothing
  print $ validate @(Operation [CustomError]) $ RawData Nothing Nothing Nothing

-- NON-ACCUMULATING
newtype Result e a = Result
  { unResult :: Either e a
  }
  deriving newtype (Functor, Applicative)
  deriving stock (Show)

newtype CustomError = CustomError String deriving Show

data RawData = RawData
  { fieldOne   :: Maybe Int
  , fieldTwo   :: Maybe Char
  , fieldThree :: Maybe Bool
  }

data ValidData = ValidData
  { fOne   :: Int
  , fTwo   :: Char
  , fThree :: Bool
  }
  deriving stock Show

validateResult :: RawData -> Result [CustomError] ValidData
validateResult RawData {..} =
  ValidData
    <$> expect "fieldOne"   fieldOne
    <*> expect "fieldTwo"   fieldTwo
    <*> expect "fieldThree" fieldThree
 where
  expect :: String -> Maybe a -> Result [CustomError] a
  expect field Nothing  = Result . Left $ [CustomError field]
  expect field (Just a) = Result $ Right a

-- ACCUMULATING
newtype Operation e a = Operation
  { unOperation :: Either e a
  }
  deriving newtype (Functor)
  deriving stock (Show)

instance Monoid e => Applicative (Operation e) where
  pure :: a -> Operation e a
  pure = Operation . Right

  (<*>) :: Operation e (a -> b) -> Operation e a -> Operation e b
  op <*> op' = case (unOperation op, unOperation op') of
    (Right f, Right a) -> Operation $ Right (f a) -- success
    (Left  e, Left e') -> Operation $ Left (e <> e') -- if both failed, accumulate errors
    (Left  e, _      ) -> Operation $ Left e -- if only first op failed, keep those errors
    (_      , Left e ) -> Operation $ Left e -- if only second op failed, keep those errors

validateOperation :: RawData -> Operation [CustomError] ValidData
validateOperation RawData {..} =
  ValidData
    <$> expect "fieldOne"   fieldOne
    <*> expect "fieldTwo"   fieldTwo
    <*> expect "fieldThree" fieldThree
 where
  expect :: String -> Maybe a -> Operation [CustomError] a
  expect field Nothing  = Operation . Left $ [CustomError field]
  expect field (Just a) = Operation $ Right a

-- Unification

class Validate e v | v -> e where
  success :: a -> v a
  refute :: e -> v a

instance Validate e (Result e) where
  success :: a -> Result e a
  success = Result . Right

  refute :: e -> Result e a
  refute = Result . Left

instance Validate e (Operation e) where
  success :: a -> Operation e a
  success = Operation . Right

  refute :: e -> Operation e a
  refute = Operation . Left

validate :: (Applicative v, Validate [CustomError] v) => RawData -> v ValidData
validate RawData {..} =
  ValidData
    <$> expect "fieldOne"   fieldOne
    <*> expect "fieldTwo"   fieldTwo
    <*> expect "fieldThree" fieldThree
 where
  expect field Nothing  = refute [CustomError field]
  expect field (Just a) = success a

nl :: IO ()
nl = putStr "\n"

tab :: IO ()
tab = putStr "\t"

-- [1]: https://gitlab.haskell.org/ghc/ghc/-/blob/master/libraries/base/Data/Either.hs