validate-blabla.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs, DataKinds, TypeFamilies #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

import Data.Proxy
import Data.Text

data State = Validated | Unvalidated | Errors deriving (Eq, Show)

type family Selector (state :: State) x where
  Selector 'Validated x = x
  Selector 'Unvalidated x = x
  Selector 'Errors x = [Text]

data Address (state :: State) = Address
  {
    _city :: Selector state Text
  , _zip :: Selector state Text
  } -- deriving (Eq, Show)

deriving instance Show (Address 'Validated)
deriving instance Show (Address 'Errors)

data Blah (state :: State) = Blah
  {
    foo :: Selector state Int
  , bar :: Selector state String
  , address :: Address state
  } -- deriving (Eq, Show)

data ValidationWrapper a (state :: State) where
  Valid :: a -> ValidationWrapper a 'Validated
  Invalid :: [Text] -> ValidationWrapper a 'Errors

data ValidationResult a = ValidationError [Text] (a 'Errors)
                        | ValidationSuccess (a 'Validated)

class Validate f g where
  validate :: f -> g

instance (Validate f' g', g ~ (ValidationWrapper a 'Validated -> g'))
  => Validate (a -> f') g where
  validate f (Valid a) = validate (f a)

instance {-# OVERLAPPABLE #-} f ~ g => Validate f g where
  validate = id

class Invalidate f g where
  invalidate :: f -> g

instance (Invalidate f' g', g ~ (ValidationWrapper a state -> g'))
  => Invalidate ([Text] -> f') g where
  invalidate f (Valid _) = invalidate (f [])
  invalidate f (Invalid e) = invalidate (f e)

instance {-# OVERLAPPABLE #-} f ~ g => Invalidate f g where
  invalidate = id

class Validator f g (b :: Bool) where
  validator :: proxy b -> f -> g

instance Validate f g => Validator f g 'True where
  validator _ = validate

instance Invalidate f g => Validator f g 'False where
  validator _ = invalidate

class AllValid f g (b :: Bool)
instance AllValid f' g' b
  => AllValid (v -> f') (ValidationWrapper a 'Validated -> g') b
instance (b ~ 'False)
  => AllValid (v -> f') (ValidationWrapper a 'Errors -> g') b
instance {-# OVERLAPPABLE #-} (f ~ f' 'Validated, f ~ g, b ~ 'True) => AllValid f g b

class SetError (b :: Bool) f g
instance SetError 'False f' g' => SetError 'False (v -> f') (a -> g')
instance {-# OVERLAPPABLE #-} (f ~ f_ 'Errors) => SetError 'False f g
instance SetError 'True f g

autoValidate :: forall f g b. (AllValid f g b, Validator f g b, SetError b f g) => f -> g
autoValidate = validator (Proxy :: Proxy b)

main = do
  print $ autoValidate Address (Valid "CITY") (Valid "ZIP")
  print $ autoValidate Address (Valid "CITY") (Invalid ["Bad zip"])