module Servant.HTML.EDE.Internal.Validate where

import Control.Applicative
import Data.Foldable
import Data.Traversable
import Data.Functor.Compose
import Data.Semigroup

data Validated e a = OK a | NotOK e
  deriving (Eq, Show)

instance Functor (Validated e) where
  fmap f (OK x)    = OK (f x)
  fmap _ (NotOK e) = NotOK e

instance Semigroup e => Applicative (Validated e) where
  pure x = OK x

  OK f    <*> OK x     = OK (f x)
  OK _    <*> NotOK e  = NotOK e
  NotOK e <*> OK _     = NotOK e
  NotOK e <*> NotOK e' = NotOK (e <> e')

instance Foldable (Validated e) where
  foldMap f (OK x)    = f x
  foldMap _ (NotOK _) = mempty

instance Traversable (Validated e) where
  traverse f (OK x)    = fmap OK (f x)
  traverse _ (NotOK x) = pure (NotOK x)

instance (Semigroup e, Semigroup a) => Semigroup (Validated e a) where
  NotOK e <> NotOK e' = NotOK (e <> e')
  NotOK e <> OK _     = NotOK e
  OK a    <> OK b     = OK (a <> b)
  OK _    <> NotOK e  = NotOK e

validateEither :: Either e a -> Validated e a
validateEither (Left e)  = NotOK e
validateEither (Right x) = OK x

eitherValidate :: Validated e a -> Either e a
eitherValidate (OK x)    = Right x
eitherValidate (NotOK e) = Left e

ok :: Applicative m => a -> ValidateT e m a
ok = VT . pure . OK

no :: Applicative m => e -> ValidateT e m a
no = VT . pure . NotOK

validated :: (e -> r) -> (a -> r) -> Validated e a -> r
validated f _ (NotOK e) = f e
validated _ f (OK x)    = f x

newtype ValidateT e m a = VT
  { runValidateT :: m (Validated e a) }

validate :: m (Validated e a) -> ValidateT e m a
validate = VT

instance Functor m => Functor (ValidateT e m) where
  fmap f (VT m) = VT $ fmap (fmap f) m

instance (Applicative m, Semigroup e) => Applicative (ValidateT e m) where
  pure = VT . pure . pure

  VT f <*> VT x = VT . getCompose $ Compose f <*> Compose x

instance (Applicative m, Semigroup e, Semigroup a) => Semigroup (ValidateT e m a) where
  VT a <> VT b = VT $ (<>) <$> a <*> b