aeson-schemas-1.0.0: test/Util.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module Util where

import Control.Exception (SomeException, try)
import Control.Monad ((<=<))
import Data.Aeson (eitherDecode)
import qualified Data.ByteString.Lazy as ByteStringL
import qualified Data.ByteString.Lazy.Char8 as Char8L
import Data.List (isPrefixOf)
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (lift)

import Data.Aeson.Schema (Object, get, schema, unwrap)
import qualified Data.Aeson.Schema.Internal as Internal

getMockedResult :: FilePath -> ExpQ
getMockedResult fp = do
  contents <- runIO $ ByteStringL.readFile fp
  [| either error id $ eitherDecode $ Char8L.pack $(lift $ Char8L.unpack contents) |]

-- | Show the expression generated by passing the given string to the 'get' quasiquoter.
showGet :: String -> ExpQ
showGet = lift . pprint <=< quoteExp get

-- | Show the type generated by passing the given string to the 'unwrap' quasiquoter.
showUnwrap :: String -> ExpQ
showUnwrap = showType <=< quoteType unwrap

-- | Show the type generated by passing the given string to the 'schema' quasiquoter.
showSchema :: String -> ExpQ
showSchema = showSchemaType <=< quoteType schema

showType :: Type -> ExpQ
showType = \case
  AppT (ConT name) schema' | name == ''Object -> [| "Object (" ++ $(showSchemaType schema') ++ ")" |]
  ty -> lift $ pprint ty

showSchemaType :: Type -> ExpQ
showSchemaType = appTypeE [| Internal.showSchema |] . pure

-- | Return the 'error' message thrown when evaluating the given expresssion.
getError :: a -> ExpQ
getError x = runIO (try $ x `seq` pure ()) >>= \case
  Right _ -> fail "'getError' expression unexpectedly succeeded"
  Left e -> lift . unlines . stripCallStack . lines . show $ (e :: SomeException)
  where
    stripCallStack [] = []
    stripCallStack (l:ls) = if "CallStack" `isPrefixOf` l
      then []
      else l : stripCallStack ls