TH.hs

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

module Tests.UnwrapQQ.TH where

import Control.DeepSeq (deepseq)
import Language.Haskell.TH (appTypeE)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.TestUtils (
  MockedMode (..),
  QMode (..),
  QState (..),
  loadNames,
  runTestQ,
  runTestQErr,
 )

import Data.Aeson.Schema (schema, unwrap)
import TestUtils (ShowSchemaResult (..), mkExpQQ)
import TestUtils.DeepSeq ()

type ListSchema = [schema| { ids: List Int } |]
type MaybeSchema = [schema| { class: Maybe Text } |]
type SumSchema = [schema| { verbosity: Int | Bool } |]
type ABCSchema =
  [schema|
  {
    a: Bool,
    b: Bool,
    c: Double,
  }
|]

type NestedSchema =
  [schema|
  {
    a: {
      b: {
        c: Bool,
      },
    },
  }
|]

type MySchema =
  [schema|
  {
    users: List {
      name: Text,
    },
  }
|]

-- Compile above schemas before these schemas
$(return [])

type ListSchema2 = [schema| { list: #ListSchema } |]
type User = [unwrap| MySchema.users[] |]
type UnwrappedNestedSchema = [unwrap| NestedSchema.a |]

type NotASchema = Int

-- Compile above types before reifying
$(return [])

qState :: QState 'FullyMocked
qState =
  QState
    { mode = MockQ
    , knownNames =
        [ ("ListSchema", ''ListSchema)
        , ("ListSchema2", ''ListSchema2)
        , ("MaybeSchema", ''MaybeSchema)
        , ("SumSchema", ''SumSchema)
        , ("ABCSchema", ''ABCSchema)
        , ("NotASchema", ''NotASchema)
        , ("UnwrappedNestedSchema", ''UnwrappedNestedSchema)
        ]
    , reifyInfo =
        $( loadNames
            [ ''ListSchema
            , ''ListSchema2
            , ''MaybeSchema
            , ''SumSchema
            , ''ABCSchema
            , ''NotASchema
            , ''MySchema
            , ''UnwrappedNestedSchema
            ]
         )
    }

-- | A quasiquoter for generating the string representation of an unwrapped schema.
--
--  Also runs the `unwrap` quasiquoter at runtime, to get coverage information.
unwrapRep :: QuasiQuoter
unwrapRep = mkExpQQ $ \s ->
  let showSchemaResultQ = appTypeE [|showSchemaResult|] (quoteType unwrap s)
   in [|runTestQ qState (quoteType unwrap s) `deepseq` $showSchemaResultQ|]

unwrapErr :: QuasiQuoter
unwrapErr = mkExpQQ $ \s -> [|runTestQErr qState (quoteType unwrap s)|]