Skip to content

Instantly share code, notes, and snippets.

@i-am-tom
Created May 8, 2019 12:49
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save i-am-tom/d2701275ae208147ebaf9b5c2a2e6613 to your computer and use it in GitHub Desktop.
Sketching out composite validation
{-# 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