{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Aeson.Schema.TH.Schema (schema) where
import Control.Monad (unless, (<=<), (>=>))
import Data.Bifunctor (second)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (mapMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Data.Aeson.Schema.Internal (SchemaType(..))
import Data.Aeson.Schema.Key (SchemaKey(..), fromSchemaKey)
import qualified Data.Aeson.Schema.Show as SchemaShow
import Data.Aeson.Schema.TH.Parse
import Data.Aeson.Schema.TH.Utils
(parseSchemaType, schemaPairsToTypeQ, typeQListToTypeQ, typeToSchemaPairs)
schema :: QuasiQuoter
schema = QuasiQuoter
{ quoteExp = error "Cannot use `schema` for Exp"
, quoteDec = error "Cannot use `schema` for Dec"
, quoteType = parse schemaDef >=> \case
SchemaDefObj items -> generateSchemaObject items
_ -> fail "`schema` definition must be an object"
, quotePat = error "Cannot use `schema` for Pat"
}
generateSchemaObject :: [SchemaDefObjItem] -> TypeQ
generateSchemaObject items = [t| 'SchemaObject $(fromItems items) |]
where
fromItems = schemaPairsToTypeQ <=< resolveParts . concat <=< mapM toParts
generateSchema :: SchemaDef -> TypeQ
generateSchema = \case
SchemaDefType "Bool" -> [t| 'SchemaBool |]
SchemaDefType "Int" -> [t| 'SchemaInt |]
SchemaDefType "Double" -> [t| 'SchemaDouble |]
SchemaDefType "Text" -> [t| 'SchemaText |]
SchemaDefType other -> [t| 'SchemaCustom $(getType other) |]
SchemaDefMaybe inner -> [t| 'SchemaMaybe $(generateSchema inner) |]
SchemaDefTry inner -> [t| 'SchemaTry $(generateSchema inner) |]
SchemaDefList inner -> [t| 'SchemaList $(generateSchema inner) |]
SchemaDefInclude other -> getType other
SchemaDefObj items -> generateSchemaObject items
SchemaDefUnion schemas -> [t| 'SchemaUnion $(typeQListToTypeQ $ map generateSchema schemas) |]
getName :: String -> Q Name
getName ty = maybe (fail $ "Unknown type: " ++ ty) return =<< lookupTypeName ty
getType :: String -> TypeQ
getType = getName >=> conT
data KeySource = Provided | Imported
deriving (Show,Eq)
toParts :: SchemaDefObjItem -> Q [(SchemaKey, TypeQ, KeySource)]
toParts = \case
SchemaDefObjPair (schemaDefKey, schemaDefType) -> do
let schemaKey = schemaDefToSchemaKey schemaDefKey
schemaType <- generateSchema schemaDefType
case schemaKey of
PhantomKey _ -> do
let schemaTypeShow = parseSchemaType schemaType
unless (isValidPhantomSchema schemaTypeShow) $
fail $ "Invalid schema for '" ++ fromSchemaKey schemaKey ++ "': " ++ SchemaShow.showSchemaType schemaTypeShow
_ -> return ()
pure . tagAs Provided $ [(schemaKey, pure schemaType)]
SchemaDefObjExtend other -> do
name <- getName other
reify name >>= \case
TyConI (TySynD _ _ (AppT (PromotedT ty) inner)) | ty == 'SchemaObject ->
pure . tagAs Imported . map (second pure) $ typeToSchemaPairs inner
_ -> fail $ "'" ++ show name ++ "' is not a SchemaObject"
where
tagAs source = map $ \(k,v) -> (k,v,source)
schemaDefToSchemaKey = \case
SchemaDefObjKeyNormal key -> NormalKey key
SchemaDefObjKeyPhantom key -> PhantomKey key
isValidPhantomSchema = \case
SchemaShow.SchemaTry _ -> True
SchemaShow.SchemaObject _ -> True
SchemaShow.SchemaUnion schemas -> all isValidPhantomSchema schemas
_ -> False
resolveParts :: [(SchemaKey, TypeQ, KeySource)] -> Q [(SchemaKey, TypeQ)]
resolveParts parts = do
resolved <- resolveParts' $ HashMap.fromListWith (++) $ map nameAndSource parts
return $ mapMaybe (alignWithResolved resolved) parts
where
nameAndSource (name, _, source) = (fromSchemaKey name, [source])
resolveParts' = HashMap.traverseWithKey $ \name sources -> do
let numOf source = length $ filter (== source) sources
case (numOf Provided, numOf Imported) of
(1, _) -> return Provided
(0, 1) -> return Imported
(x, _) | x > 1 -> fail $ "Key '" ++ name ++ "' specified multiple times"
(_, x) | x > 1 -> fail $ "Key '" ++ name ++ "' declared in multiple imported schemas"
_ -> fail "Broken invariant in resolveParts"
alignWithResolved resolved (key, ty, source) =
let resolvedSource = resolved HashMap.! fromSchemaKey key
in if resolvedSource == source
then Just (key, ty)
else Nothing