Deriving generic validators from types.

Deriving.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Deriving where

import Control.Applicative ((<|>))
import Data.Either (Either (..))
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import GHC.Generics
import GHC.TypeLits

-- Thanks, Bastien!

newtype Validation e a
  = Validation (Either e a)
  deriving (Eq, Ord, Show, Functor)

instance Semigroup e => Applicative (Validation e) where
  pure
    = Validation . Right

  Validation fs <*> Validation xs
    = Validation $ case fs of
        Left e  -> case xs of Right _  -> Left  e
                              Left  e' -> Left (e <> e')
        Right f -> fmap f xs

throw :: e -> Validation e a
throw = Validation . Left

orElse :: Validation e a -> Validation e a -> Validation e a
orElse yay@(Validation (Right x)) _ = yay
orElse _ x = x

-- Formalising.

data Person
  = Person
      { forename :: Forename
      , surname  :: Surname
      , age      :: Age
      }
  deriving (Eq, Generic, Show)

newtype Nested a
  = Nested a
  deriving (Eq, Show)

data Applicant
  = Primary (Nested Person)
  | Secondary (Nested Person)
  deriving (Eq, Generic, Show)

newtype Forename = Forename { get :: String }
  deriving (Eq, Generic, Show)
  deriving HasValidation via Name

newtype Surname = Surname { get :: String }
  deriving (Eq, Generic, Show)
  deriving HasValidation via Name

newtype Age = Age { get :: Int }
  deriving (Eq, Generic, Show)

-------------------------------------------------------------------------------
-- Validation.

class HasValidation (a :: Type) where
  validate :: String -> Validation [String] a

newtype Name = Name String

instance HasValidation Name where
  validate raw
    = if length raw > 2
        then pure (Name raw)
        else throw ["This isn't a real name!"]

instance HasValidation Age where
  validate raw
    = case reads @Int raw of
        [(number, "")] -> pure (Age number)
        _              -> throw ["This isn't a number!"]

-- Budget JSON library!
type Json = String

selectField :: String -> Json -> Maybe Json
selectField fieldName _ = Just "222"

---

class Form (thing :: Type) where
  readForm :: Json -> Validation [String] thing

instance {-# OVERLAPPABLE #-} GForm inner => GForm (M1 sort meta inner) where
  greadForm = fmap M1 . greadForm

instance (KnownSymbol name, GForm inner)
    => GForm (S1 ('MetaSel ('Just name) i d c) inner) where
  greadForm json
    = case selectField name json of
        Just field -> fmap M1 (greadForm field)
        Nothing    -> throw ["Couldn't find field " <> name]
    where
      name = symbolVal (Proxy @name)

instance {-# OVERLAPPABLE #-} Form thing
    => GForm (Rec0 (Nested thing)) where
  greadForm = fmap (K1 . Nested) . readForm

instance {-# OVERLAPPABLE #-} HasValidation thing => GForm (Rec0 thing) where
  greadForm = fmap K1 . validate

class GSum (rep :: Type -> Type) where
  greadSum :: Json -> Validation [String] (rep p)

instance (GSum left, GSum right) => GSum (left :+: right) where
  greadSum json = fmap L1 (greadSum json) `orElse` fmap R1 (greadSum json)

instance (KnownSymbol name, GForm thing)
    => GSum (C1 ('MetaCons name lol wut) thing) where
  greadSum json
    = if maybe False (== name) (selectField "type" json)
        then fmap M1 (greadForm json)
        else throw ["Well, it's definitely not a " <> name]
    where
      name = symbolVal (Proxy @name)

instance (GSum (left :+: right), GForm left, GForm right)
    => GForm (left :+: right) where
  greadForm = greadSum

instance (GForm left, GForm right) => GForm (left :*: right) where
  greadForm json = (:*:) <$> greadForm json <*> greadForm json

instance (Generic thing, GForm (Rep thing)) => Form thing where
  readForm = fmap to . greadForm

class GForm (rep :: Type -> Type) where
  greadForm :: Json -> Validation [String] (rep p)

test :: Validation [String] Applicant
test = readForm "this is JSON"