Enforcing data model constraints on type level.

Model.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Model where

import Control.Monad
import Data.Aeson.TH
import Data.Monoid
import Data.Proxy

import TypeSorcery
import TypeSorceryTH

import qualified Language.Haskell.TH as TH

-- =======================================================================
-- Some examples:
--
-- >>> mempty { schemaName = "Pet" } :: Schema TyObject
-- Schema {schemaName = "Pet", schemaDescription = Nothing, schemaProperties = []}
--
-- >>> mempty { schemaName = "Age" } :: Schema TyInteger
-- Schema {schemaName = "Age", schemaDescription = Nothing, schemaProperties = Absent}
--
-- >>> eitherDecode "{\"schemaType'\": \"TyInteger\", \"schemaName'\": \"val\"}" :: Either String (Some (Valid Schema'))
-- Right (Some (Schema {schemaName = "val", schemaDescription = Nothing, schemaProperties = Nothing}))
--
-- >>> eitherDecode "{\"schemaType'\": \"TyObject\", \"schemaName'\": \"val\", \"schemaProperties'\": []}" :: Either String (Some (Valid Schema'))
-- Right (Some (Schema {schemaName = "val", schemaDescription = Nothing, schemaProperties = []}))

data Type
  = TyInteger
  | TyDouble
  | TyObject
  deriving (Eq, Show)

-- -----------------------------------------------------------------------
-- "Typed" Model
-- -----------------------------------------------------------------------

class KnownType ty where
  knownType :: proxy ty -> Type

instance KnownType TyObject where knownType _ = TyObject
instance KnownType TyInteger where knownType _ = TyInteger
instance KnownType TyDouble where knownType _ = TyDouble

type family SchemaProperties ty where
  SchemaProperties TyObject = [Some (Valid Schema')]
  SchemaProperties ty = Absent

data Schema ty = Schema
  { schemaName        :: String
  , schemaDescription :: Maybe String
  , schemaProperties  :: SchemaProperties ty
  }

deriving instance Eq (SchemaProperties ty) => Eq (Schema ty)
deriving instance Show (SchemaProperties ty) => Show (Schema ty)

instance Monoid (SchemaProperties ty) => Monoid (Schema ty) where
  mempty = Schema mempty mempty mempty
  Schema a b c `mappend` Schema x y z = Schema (a <> x) (b <> y) (c <> z)

instance
  ( KnownType ty
  , Valid (Maybe [Schema']) (SchemaProperties ty)
  ) => Valid Schema' (Schema ty) where
  fromValid Schema{..} = Schema'
    { schemaType' = knownType (Proxy :: Proxy ty)
    , schemaName' = schemaName
    , schemaDescription' = schemaDescription
    , schemaProperties' = fromValid schemaProperties }

  validate Schema'{..} = do
    when (schemaType' /= knownType (Proxy :: Proxy ty)) $
      fail "Invalid type"
    props <- validate schemaProperties'
    return $ Schema
      { schemaName = schemaName'
      , schemaDescription = schemaDescription'
      , schemaProperties = props }

-- -----------------------------------------------------------------------
-- "Untyped" Model
-- -----------------------------------------------------------------------

data Schema' = Schema'
  { schemaType' :: Type
  , schemaName' :: String
  , schemaDescription' :: Maybe String

  -- | Required for TyObject, nothing for any other type.
  , schemaProperties' :: Maybe [Schema']
  } deriving (Show)

instance Monoid Schema' where
  mempty = Schema' TyObject "" Nothing Nothing
  Schema' _ a b c `mappend` Schema' t x y z = Schema' t (name a x) (lst b y) (lst c z)
    where
      name a "" = a
      name _ x  = x

      lst :: Maybe a -> Maybe a -> Maybe a
      lst b Nothing = b
      lst _ y = y

deriveJSON defaultOptions ''Schema'
deriveJSON defaultOptions ''Type

deriveDispatch ''Schema' 'schemaType' ''Type ''Schema

deriveModel defaultModelOptions
  { modelOverrideFields = \model ->
      [ ('schemaProperties, [t| Maybe [$model] |] ) ]
  } ''Schema

TypeSorcery.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module TypeSorcery where

import Control.Monad
import Data.Aeson
import Data.Monoid
import Data.Proxy
import Data.Type.Equality

data Absent = Absent deriving (Eq, Show)

data SomeProxy p = forall a. p a => SomeProxy (Proxy a)

data Some p = forall a. p a => Some a

class Valid model valid where
  validate :: model -> Either String valid
  fromValid :: valid -> model

class Dispatch model where
  dispatch :: model -> Maybe (SomeProxy (Valid model))

validateAs :: Valid model valid => Proxy valid -> model -> Either String valid
validateAs _ = validate

instance (Eq model, Dispatch model) => Eq (Some (Valid model)) where
  x == y = fromValid x == (fromValid y :: model)

instance (Show model, Dispatch model) => Show (Some (Valid model)) where
  show x = show (fromValid x :: model)

instance (Monoid model, Dispatch model) => Monoid (Some (Valid model)) where
  mempty =
    case validate (mempty :: model) of
      Left err -> error $ "mempty: " ++ err
      Right x  -> x

  x `mappend` y =
    case validate (fromValid x `mappend` fromValid y :: model) of
      Left err -> error $ "mappend: " ++ err
      Right x  -> x

instance (ToJSON model, Dispatch model) => ToJSON (Some (Valid model)) where
  toJSON x = toJSON (fromValid x :: model)

instance (FromJSON model, Dispatch model) => FromJSON (Some (Valid model)) where
  parseJSON json = do
    (model :: model) <- parseJSON json
    case validate model of
      Left err -> fail err
      Right valid -> pure valid

instance Dispatch model => Valid model (Some (Valid model)) where
  fromValid (Some valid) = fromValid valid
  validate model =
    case dispatch model of
      Nothing -> fail "failed to dispatch"
      Just (SomeProxy proxy) -> Some <$> validateAs proxy model

instance Valid model valid => Valid [model] [valid] where
  fromValid = map fromValid
  validate = traverse validate

instance Valid model valid => Valid (Maybe model) (Maybe valid) where
  fromValid = fmap fromValid
  validate = traverse validate

instance {-# OVERLAPPABLE #-} Valid model valid => Valid (Maybe model) valid where
  fromValid = Just . fromValid
  validate Nothing = fail "cannot validate Nothing"
  validate (Just x) = validate x

instance {-# OVERLAPPING #-} Valid (Maybe model) Absent where
  fromValid _ = Nothing
  validate Nothing  = pure Absent
  validate _ = fail "expected Nothing for Absent"

instance (Eq m, Monoid m) => Valid m Absent where
  fromValid _ = mempty
  validate x
    | x == mempty = pure Absent
    | otherwise   = fail "expected mempty for Absent"

instance Valid a a where
  fromValid = id
  validate = pure

instance Monoid Absent where
  mempty = Absent
  mappend _ _ = Absent

TypeSorceryTH.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module TypeSorceryTH where

import Data.Char
import Data.Proxy
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (VarStrictType)

import TypeSorcery

deriveDispatch :: Name -> Name -> Name -> Name -> Q [Dec]
deriveDispatch name field ty con = do
  tyInfo <- reify ty
  case tyInfo of
    TyConI (DataD _ _ _ cs _) -> do
      deriveDispatch' (map normalName cs)
    _ -> fail "not a type constructor"
  where
    normalName (NormalC n []) = n
    normalName _ = error "not a normal constructor without parameters"

    deriveDispatch' :: [Name] -> Q [Dec]
    deriveDispatch' ns = do
      dispatchName <- newName "dispatch"
      let dispatchClauses = flip map ns $ \n -> do
            npat <- conP n []
            rhs <- [| Just (SomeProxy (Proxy :: Proxy ($(conT con) $(conT n)))) |]
            return $ Clause [npat] (NormalB rhs) []
      dispatchDec <- funD dispatchName dispatchClauses
      instDecs <- [d| instance Dispatch $(conT name) where dispatch model = $(varE dispatchName) ($(varE field) model) |]
      return (dispatchDec : instDecs)

data ModelOptions = ModelOptions
  { modelNameModifier       :: String -> String
  , modelTypeFieldModifier  :: String -> String -> String
  , modelFieldModifier      :: String -> String -> String
  , modelOverrideFields     :: Q Type -> [(Name, Q Type)]
  }

defaultModelOptions :: ModelOptions
defaultModelOptions = ModelOptions
  { modelNameModifier      = (++ "Model")
  , modelTypeFieldModifier = fieldModifier
  , modelFieldModifier     = fieldModifier
  , modelOverrideFields    = const []
  }
  where
    fieldModifier modelName tyName = lowerHead modelName ++ upperHead tyName 
    lowerHead (c:cs) = toLower c : cs
    upperHead (c:cs) = toUpper c : cs

deriveModel :: ModelOptions -> Name -> Q [Dec]
deriveModel ModelOptions{..} validName = do
  validInfo <- reify validName
  case validInfo of
    TyConI (DataD _ _ tyVars [RecC _ recFields] _) -> deriveModel' tyVars recFields
    _ -> fail "not a single constructor record data type"

  where
    modelNameStr = modelNameModifier (nameBase validName)

    modelName = mkName modelNameStr

    deriveModel' :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]
    deriveModel' tyVars recFields = do
      modelTyFields <- traverse mkTyField tyVars
      modelRecFields <- flip traverse recFields $ \(rName, rStrict, rType) -> do
          rType' <-
            case lookup rName (modelOverrideFields (return $ ConT modelName)) of
              Nothing -> return rType
              Just t  -> t
          return (mkName (modelFieldModifier modelNameStr (nameBase rName)), rStrict, rType')
      let modelFields = modelRecFields ++ modelTyFields
      return [DataD [] modelName [] [RecC modelName modelFields] []]

    mkTyFieldName :: Name -> Name
    mkTyFieldName tyName = mkName (modelTypeFieldModifier modelNameStr (nameBase tyName))

    mkTyField :: TyVarBndr -> Q VarStrictType
    mkTyField (KindedTV tyName tyKind) = return (mkTyFieldName tyName, NotStrict, tyKind)
    mkTyField (PlainTV tyName) = do
      fail $ unlines
        [ "can't derive type for field `" ++ nameBase (mkTyFieldName tyName) ++ "':"
        , "need explicit kind signature for type param `" ++ nameBase tyName ++ "'" ]