Schemas.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}

module Benchmarks.Data.Schemas
  ( module Benchmarks.Data.Schemas
  , module Benchmarks.Data.Schemas.TH
  ) where

import Control.Monad (forM)
import Data.Char (chr, toUpper)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
import Language.Haskell.TH.TestUtils ()

import Benchmarks.Data.Schemas.TH

-- Generates:
--
--   type Schema1   = { a1: Int }
--   type Schema5   = { a1: Int, a2: Int, ... a5: Int }
--   type Schema10  = { a1: Int, a2: Int, ... a10: Int }
--   type Schema100 = { a1: Int, a2: Int, ... a100: Int }
$(do
  -- The sizes of schemas to generate
  let schemaSizes = [1, 5, 10, 100]
      allSchemas = flip map schemaSizes $ \n ->
        let name = "Schema" ++ show n
        in (n, name, mkName name)

  concat <$> sequence
    [ forM allSchemas $ \(n, _, name) -> genSchema name $ keysTo n
    , [d|
        sizedSchemas :: [(Int, String)]
        sizedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name))

        sizedSchemasNames :: [(String, Name)]
        sizedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))
      |]
    ]
  )

-- Generates:
--
--   type SchemaNest1   = { a1: Int }
--   type SchemaNest5   = { a1: { a2: { ... a5: Int } }
--   type SchemaNest10  = { a1: { a2: { ... a10: Int } }
--   type SchemaNest100 = { a1: { a2: { ... a100: Int } }
$(do
  -- The depths of schemas to generate
  let schemaSizes = [1, 5, 10, 100]
      allSchemas = flip map schemaSizes $ \n ->
        let name = "SchemaNest" ++ show n
        in (n, name, mkName name)

  concat <$> sequence
    [ forM allSchemas $ \(n, _, name) -> genSchema' name $
        foldr (\i inner -> genSchemaDef [Field (mkField i) inner]) "Int" [1..n]
    , [d|
        nestedSchemas :: [(Int, String)]
        nestedSchemas = $(lift $ flip map allSchemas $ \(n, name, _) -> (n, name))

        nestedSchemasNames :: [(String, Name)]
        nestedSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))
      |]
    ]
  )

-- Generates:
--
--   type SchemaA1 = { a1: Int }
--   type SchemaB1 = { b1: Int }
--   ...
--   type SchemaZ1 = { z1: Int }
--   type SchemaA2 = { a2: Int }
--   type SchemaB2 = { a2: Int }
--   ...
$(do
  let numSchemas = 100
      allSchemas = flip map [1..numSchemas] $ \n ->
        let (q, r) = n `divMod` 26
            c = chr $ 97 + r -- a .. z
            field = c : show q
            name = "Schema" ++ map toUpper field
        in (field, name, mkName name)

  concat <$> sequence
    [ forM allSchemas $ \(field, _, name) -> genSchema name [Field field "Int"]
    , [d|
        singleSchemas :: [String]
        singleSchemas = $(lift $ flip map allSchemas $ \(_, name, _) -> name)

        singleSchemasNames :: [(String, Name)]
        singleSchemasNames = $(lift $ flip map allSchemas $ \(_, name, thName) -> (name, thName))
      |]
    ]
  )