TH.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Tests.SchemaQQ.TH where

import Control.DeepSeq (deepseq)
import Data.Aeson (FromJSON, ToJSON)
import Foreign.C (CBool (..))
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, showSchema)
import TestUtils (mkExpQQ)
import TestUtils.DeepSeq ()

type UserSchema = [schema| { name: Text } |]
type ExtraSchema = [schema| { extra: Text } |]
type ExtraSchema2 = [schema| { extra: Maybe Text } |]

newtype Status = Status Int
  deriving (Show, FromJSON, ToJSON)

-- | The type referenced here should not be imported in SchemaQQ.hs nor included in 'knownNames'.
type SchemaWithHiddenImport = [schema| { a: CBool } |]

deriving instance ToJSON CBool
deriving instance FromJSON CBool

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

type WithUser = [schema| { user: #UserSchema } |]

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

qState :: QState 'FullyMocked
qState =
  QState
    { mode = MockQ
    , knownNames =
        [ ("Status", ''Status)
        , ("UserSchema", ''UserSchema)
        , ("ExtraSchema", ''ExtraSchema)
        , ("ExtraSchema2", ''ExtraSchema2)
        , ("Tests.SchemaQQ.TH.UserSchema", ''UserSchema)
        , ("Tests.SchemaQQ.TH.ExtraSchema", ''ExtraSchema)
        , ("SchemaWithHiddenImport", ''SchemaWithHiddenImport)
        , ("WithUser", ''WithUser)
        , ("Int", ''Int)
        ]
    , reifyInfo =
        $( loadNames
            [ ''UserSchema
            , ''ExtraSchema
            , ''ExtraSchema2
            , ''SchemaWithHiddenImport
            , ''WithUser
            , ''Int
            ]
         )
    }

{- | A quasiquoter for generating the string representation of a schema.

 Also runs the `schema` quasiquoter at runtime, to get coverage information.
-}
schemaRep :: QuasiQuoter
schemaRep = mkExpQQ $ \s ->
  let schemaType = quoteType schema s
      showSchemaQ = appTypeE [|showSchema|] schemaType
   in [|runTestQ qState (quoteType schema s) `deepseq` $showSchemaQ|]

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