Created
May 8, 2019 12:49
Star
You must be signed in to star a gist
Sketching out composite validation
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE AllowAmbiguousTypes #-} | |
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE DefaultSignatures #-} | |
{-# LANGUAGE DeriveGeneric #-} | |
{-# LANGUAGE DerivingStrategies #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE GeneralisedNewtypeDeriving #-} | |
{-# LANGUAGE LambdaCase #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TypeApplications #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE UndecidableInstances #-} | |
module Service where | |
import qualified Data.HashMap.Strict as HashMap | |
import Control.Applicative (liftA2) | |
import qualified Data.Aeson as Json | |
import Data.Kind (Type) | |
import Data.Text (Text) | |
import qualified Data.Text as Text | |
import GHC.Generics | |
-- import Data.Generic.HKD | |
import GHC.TypeLits | |
import Data.Proxy | |
import Control.Monad ((<=<)) | |
----------------------------------------------------------- | |
-- VALIDATION API. | |
class Validation (input :: Type) where | |
validate :: Json.Value -> Either Json.Value input | |
unvalidate :: input -> Json.Value | |
-- Data types that should have their components validated _first_. | |
newtype Composite (structure :: Type) | |
= Composite { getComposite :: structure } | |
deriving newtype (Eq, Show) | |
class GComposite (rep :: Type -> Type) where | |
gvalidate :: Json.Value -> Either Json.Value (rep p) | |
gunvalidate :: rep p -> Json.Value | |
instance GComposite inner => GComposite (D1 meta inner) where | |
gvalidate = fmap M1 . gvalidate | |
gunvalidate = gunvalidate . unM1 | |
class GCompositeObject (rep :: Type -> Type) where | |
gvalidateObject :: Json.Object -> Either Json.Value (rep p) | |
gunvalidateObject :: rep p -> Json.Object | |
instance (GCompositeObject left, GCompositeObject right) | |
=> GCompositeObject (left :*: right) where | |
gvalidateObject | |
= liftA2 (:*:) <$> gvalidateObject | |
<*> gvalidateObject | |
gunvalidateObject (left :*: right) | |
= gunvalidateObject left | |
<> gunvalidateObject right | |
instance GComposite inner -- Single-argument branches. | |
=> GComposite (C1 meta (S1 meta inner)) where | |
gvalidate = fmap (M1 . M1) . gvalidate | |
gunvalidate = gunvalidate . unM1 . unM1 | |
instance {-# OVERLAPPABLE #-} GCompositeObject inner | |
=> GComposite (C1 ('MetaCons must be 'True) inner) where | |
gvalidate = \case | |
Json.Object obj -> fmap M1 (gvalidateObject obj) | |
_ -> Left "Oops" | |
gunvalidate = Json.Object . gunvalidateObject . unM1 | |
label :: forall x. KnownSymbol x => Text | |
label = Text.pack (symbolVal (Proxy @x)) | |
instance (GComposite inner, KnownSymbol name) | |
=> GCompositeObject (S1 ('MetaSel ('Just name) i d c) inner) where | |
gvalidateObject object | |
= case HashMap.lookup (label @name) object of | |
Just key -> fmap M1 (gvalidate key) | |
Nothing -> Left "Uh oh" | |
gunvalidateObject | |
= HashMap.singleton (label @name) | |
. gunvalidate | |
. unM1 | |
instance Validation inner => GComposite (Rec0 inner) where | |
gvalidate = fmap K1 . validate | |
gunvalidate = unvalidate . unK1 | |
----------------------------------------------------------- | |
data User | |
= User | |
{ name :: String | |
, age :: Int | |
} | |
deriving Generic | |
instance GComposite (Rep User) => Validation User where | |
validate = fmap to . gvalidate | |
unvalidate = gunvalidate . from | |
f = unvalidate (User "Tom" 5) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment