Retaining parallel semantics in a free monad

free.hs

{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE ExistentialQuantification #-}

import Data.Semigroup

example :: Validation [String] Int Int
example = do
  x <- (+) <$> validation ["not even"] even
           <*> validation ["not positive"] (0 <)
  y <- validation ["not divisible by four"] (\a -> a `mod` 4 == 0)
  return (x + y)

main :: IO ()
main = mapM_ (\n -> print (n, runValidation example n)) [12, 0, 1, -1, 10]


-- Free Applicative
data FreeA f a = PureA a | forall x. Ap (f x) (FreeA f (x -> a))

liftFreeA :: f a -> FreeA f a
liftFreeA m = Ap m (PureA id)

instance Functor (FreeA f) where
  fmap f (PureA x) = PureA (f x)
  fmap f (Ap m k)  = Ap m (fmap (f .) k)

instance Applicative (FreeA f) where
  pure = PureA
  PureA f  <*> xm      = fmap f xm
  fm       <*> PureA x = fmap ($ x) fm
  Ap xm fk <*> am      = Ap xm $ flip <$> fk <*> am


-- Free Monad
data FreeM f a = PureM a | StepM (f (FreeM f a))

instance Functor f => Functor (FreeM f) where
  fmap f (PureM x) = PureM (f x)
  fmap f (StepM m) = StepM (fmap (fmap f) m)

instance Applicative f => Applicative (FreeM f) where
  pure = return
  PureM  f <*> mx       = fmap f mx
  StepM mf <*> PureM x  = StepM (fmap (fmap ($ x)) mf)
  StepM mf <*> StepM mx = StepM ((<*>) <$> mf <*> mx) -- use f as Applicative

instance Applicative f => Monad (FreeM f) where
  return = PureM
  PureM x >>= k = k x
  StepM m >>= k = StepM (fmap (>>= k) m)

liftFreeM :: Functor f => f a -> FreeM f a
liftFreeM m = StepM (fmap PureM m)


--
-- Validation
--

data VF e b a = VF e (b -> Bool) (b -> a) deriving Functor

type ValidationA e b = FreeA (VF e b)

validationA :: e -> (a -> Bool) -> ValidationA e a a
validationA e p = liftFreeA (VF e p id)

runValidationA :: Semigroup e => ValidationA e b a -> b -> Either e a
runValidationA (PureA x) _ = Right x
runValidationA (Ap (VF e p k) m) x = case runValidationA m x of
  Left e' -> Left (if p x then e' else e <> e')
  Right f -> if p x then Right (f $ k x) else Left e


type Validation e b = FreeM (FreeA (VF e b))  -- two layers of frees

validation :: e -> (a -> Bool) -> Validation e a a
validation e p = liftFreeM (liftFreeA (VF e p id))

runValidation :: Semigroup e => Validation e b a -> b -> Either e a
runValidation (PureM x) _ = Right x
runValidation (StepM m) x = runValidationA m x >>= flip runValidation x