Partial Success Data Type

Partial.hs

module PartialSuccess where

import Control.Applicative
import Control.Monad
import Data.Either (lefts, rights)
import Data.Monoid hiding (All)

--------------------------------------------------------------------------------
     -- Partial: a data type for tracking success and failure --
--------------------------------------------------------------------------------
-- | Computations where we want to track failures and successes
data Partial e a
  = All [a]
  | Some [e] [a]
  | None [e]
  | Blank
    deriving (Show, Eq)

-- | Maps over success path
instance Functor (Partial e) where
  fmap f (All xs) = All (fmap f xs)
  fmap f (Some es xs) = Some es (fmap f xs)
  fmap _ (None es) = None es
  fmap _ Blank = Blank

-- | Merging two partials merges their respective successes and failures
instance Monoid (Partial a e) where
  mempty = Blank
  mappend Blank x                     = x
  mappend x Blank                     = x
  mappend (All xs) (All xs')          = All (xs <> xs')
  mappend (All xs) (Some es' xs')     = Some es' (xs <> xs')
  mappend (All xs) (None es)          = Some es xs
  mappend (Some es xs) (All xs')      = Some es (xs <> xs')
  mappend (Some es xs) (Some es' xs') = Some (es <> es') (xs <> xs')
  mappend (Some es xs) (None es')     = Some (es <> es') xs
  mappend (None es) (All xs)          = Some es xs
  mappend (None es) (Some es' xs')    = Some (es <> es') xs'
  mappend (None es) (None es')        = None (es <> es')

-- | Apply as many functions to as many elems as there are
ap' :: [a -> b] -> [a] -> [b]
ap' = zipWith (\f x -> f x)

-- | Semantics:
-- * A complete success on all accounts: a chain of only 'All's
-- * Partial success: All <*> Some, Some <*> All, Some <*> Some
-- * Failures: everything else; discards any successes
--
-- >>> (+) <$> All [1,2,3] <*> All [10,10,10]
-- All [11,12,13]
-- >>> (+) <$> All [1,2,3] <*> None [10,10,10]
-- None [10,10,10]
-- >>> (+) <$> All [1,2,3] <*> Blank
-- Blank
-- >>> (+) <$> Blank <*> All [1,2,3]
-- Blank
-- >>> (+) <$> Blank <*> Blank
-- Blank
-- >>> (+) <$> Some [3,4,5] [1,2] <*> Some [2,3,4] [1,2,3]
-- Some [3,4,5,2,3,4] [2,4]
instance Applicative (Partial e) where
  pure x                          = All [x]
  (All fxs) <*> (All xs)          = All (ap' fxs xs)
  (All fxs) <*> (Some es' xs)     = Some es' (ap' fxs xs)
  (All _  ) <*> (None es')        = None es'
  (All _  ) <*> Blank             = Blank
  (Some es fxs) <*> (All xs)      = Some es (ap' fxs xs)
  (Some es fxs) <*> (Some es' xs) = Some (es <> es') (ap' fxs xs)
  (Some es _  ) <*> (None es')    = None (es <> es')
  (Some es _  ) <*> Blank         = None es
  (None es) <*> (All _ )          = None es
  (None es) <*> (Some es' _ )     = None (es <> es')
  (None es) <*> (None es')        = None (es <> es')
  (None es) <*> Blank             = None es
  Blank <*> (All _ )              = Blank
  Blank <*> (Some es' _ )         = None es'
  Blank <*> (None es')            = None es'
  Blank <*> Blank                 = Blank

-- | Partial alternatives
-- Choose the most successful computation from given alternatives
-- All > Some > None > Blank
instance Alternative (Partial e) where
  empty                           = Blank
  (All xs) <|> _                  = All xs
  _        <|> (All xs')          = All xs'
  (Some es xs) <|> _              = Some es xs
  (None es) <|> _                 = None es
  Blank <|> x                     = x

-- | Non-determinsm sort of Monad
-- TODO: semantics are wildly different from Applicative
--   * Needs a fix
-- >>> All [1,2,3] >>= (\xs -> Some [0] [2,3,4] >>= (\ys -> return $ xs + ys))
-- Some [0,0,0] [3,4,5,4,5,6,5,6,7]
instance Monad (Partial e) where
  return x            = All [x]
  (All xs) >>= f      = mconcat (map f xs)
  (Some es xs) >>= f  = None es <> mconcat (map f xs)
  (None es) >>= _     = None es
  Blank >>= _         = Blank

instance MonadPlus (Partial e) where
  mzero = empty
  mplus = (<|>)

--------------------------------------------------------------------------------
                            -- Examples --
--------------------------------------------------------------------------------
data Color = R | G | B deriving (Show, Eq)
data ColorError
  = BadColor
  | NotCoolColor
  | PlannedColor
    deriving (Show, Eq)

parseColors :: String -> [Either ColorError Color]
parseColors stream = case stream of
  ('r':xs) -> [Right R] <> parseColors xs
  ('g':xs) -> [Right G] <> parseColors xs
  ('b':xs) -> [Right B] <> parseColors xs
  ('p':xs) -> [Left PlannedColor] <> parseColors xs
  ('o':xs) -> [Left NotCoolColor] <> parseColors xs
  (_:xs)   -> [Left BadColor] <> parseColors xs
  []       -> []

parseColors' :: String -> Partial ColorError Color
parseColors' stream = case stream of
  ('r':xs) -> pure R <> parseColors' xs
  ('g':xs) -> pure G <> parseColors' xs
  ('b':xs) -> pure B <> parseColors' xs
  ('p':xs) -> None [PlannedColor] <> parseColors' xs
  ('w':xs) -> None [NotCoolColor] <> parseColors' xs
  (_:xs)   -> None [BadColor] <> parseColors' xs
  []       -> All []

toPartial :: [Either e a] -> Partial e a
toPartial xs =
  case (lefts xs, rights xs) of
    ([], []) -> Blank
    (ls, []) -> None ls
    ([], rs) -> All rs
    (ls, rs) -> Some ls rs