haxl-2.4.0.0: tests/TestTypes.hs

-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}

module TestTypes
   ( UserEnv
   , Haxl
   , HaxlEnv
   , lookupInput
   , Id(..)
   ) where

import Data.Aeson
import Data.Binary (Binary)
import qualified Data.Text as Text
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Aeson.Key (toText)
#else
import qualified Data.HashMap.Strict as KeyMap
#endif
import Data.Hashable
import Data.Typeable

import Haxl.Core

#if !MIN_VERSION_aeson(2,0,0)
type Key = Text.Text

toText :: Key -> Text.Text
toText = id
#endif

type UserEnv = Object
type Haxl a = GenHaxl UserEnv () a
type HaxlEnv = Env UserEnv ()

lookupInput :: FromJSON a => Key -> Haxl a
lookupInput field = do
  mb_val <- env (KeyMap.lookup field . userEnv)
  case mb_val of
    Nothing ->
      throw (NotFound (Text.concat ["field ", toText field, " was not found."]))
    Just val ->
      case fromJSON val of
        Error str ->
          throw (UnexpectedType (Text.concat
            ["field ", toText field, ": ", Text.pack str]))
        Success a -> return a


newtype Id = Id Int
  deriving (Eq, Ord, Binary, Enum, Num, Integral, Real, Hashable, Typeable,
            ToJSON, FromJSON)

instance Show Id where
  show (Id i) = show i