-- 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 FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Support for using Haxl as a DSL.  This module provides most of
-- the standard Prelude, plus a selection of stuff that makes
-- Haxl client code cleaner and more concise.
--
-- We intend Haxl client code to:
--
--  * Import @Haxl.Prelude@
--
--  * Use @RebindableSyntax@.  This implies @NoImplicitPrelude@, and
--    allows @if@-@then@-@else@ to be used with a monadic condition.
--
--  * Use @OverloadedStrings@  (we use @Text@ a lot)
--
module Haxl.Prelude (
    -- * The Standard Haskell Prelude
    -- | Everything from "Prelude" except 'mapM', 'mapM_',
    -- 'sequence', and 'sequence'
    module Prelude,

    -- * Haxl and Fetching data
    GenHaxl, dataFetch, DataSource, memo,
    memoize, memoize1, memoize2,

    -- * Extra Monad and Applicative things
    Applicative(..),
    mapM, mapM_, sequence, sequence_, filterM, foldM,
    forM, forM_,
    foldl', sort,
    Monoid(..),
    join,
    andThen,

    -- * Lifted operations
    IfThenElse(..),
    (.>), (.<), (.>=), (.<=),
    (.==), (./=), (.&&), (.||),
    (.++),
    pair,
    pAnd, pOr,

    -- * Text things
    Text,
    IsString(..),

    -- * Exceptions
    throw, catch, try, withDefault, catchAny,
    HaxlException(..), TransientError(..), LogicError(..),
    NotFound(..), UnexpectedType(..), FetchError(..),
    EmptyList(..), InvalidParameter(..)

  ) where

import Haxl.Core.DataSource
import Haxl.Core.Exception
import Haxl.Core.Memo
import Haxl.Core.Monad
import Haxl.Core.Fetch
import Haxl.Core.Parallel

import Control.Applicative
import Control.Monad (foldM, join, void)
import Data.List (foldl', sort)
import Data.Text (Text)
import Data.Traversable hiding (forM, mapM, sequence)
import GHC.Exts (IsString(..))
import Prelude hiding (mapM, mapM_, sequence, sequence_)
import Data.Maybe
import Control.Exception (fromException)

infixr 3 .&&
infixr 2 .||
infix  4 .>, .<, .>=, .<=, .==, ./=

-- -----------------------------------------------------------------------------
-- Haxl versions of Haskell Prelude stuff

-- Using overloading and RebindableSyntax to hide the monad as far as
-- possible.

class IfThenElse a b where
  ifThenElse :: a -> b -> b -> b

instance IfThenElse Bool a where
  ifThenElse :: Bool -> a -> a -> a
ifThenElse Bool
b a
t a
e = if Bool
b then a
t else a
e

-- The equality constraint is necessary to convince the typechecker that
-- this is valid:
--
-- > if ipGetCountry ip .== "us" then ... else ...
--
instance (u1 ~ u2) => IfThenElse (GenHaxl u1 w Bool) (GenHaxl u2 w a) where
  ifThenElse :: GenHaxl u1 w Bool
-> GenHaxl u2 w a -> GenHaxl u2 w a -> GenHaxl u2 w a
ifThenElse GenHaxl u1 w Bool
fb GenHaxl u2 w a
t GenHaxl u2 w a
e = do
    Bool
b <- GenHaxl u1 w Bool
GenHaxl u2 w Bool
fb
    if Bool
b then GenHaxl u2 w a
t else GenHaxl u2 w a
e

instance Num a => Num (GenHaxl u w a) where
  + :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
(+)         = (a -> a -> a) -> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Num a => a -> a -> a
(+)
  (-)         = (a -> a -> a) -> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (-)
  * :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
(*)         = (a -> a -> a) -> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Num a => a -> a -> a
(*)
  fromInteger :: Integer -> GenHaxl u w a
fromInteger = a -> GenHaxl u w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> GenHaxl u w a) -> (Integer -> a) -> Integer -> GenHaxl u w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger
  abs :: GenHaxl u w a -> GenHaxl u w a
abs         = (a -> a) -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
forall a. Num a => a -> a
abs
  signum :: GenHaxl u w a -> GenHaxl u w a
signum      = (a -> a) -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
forall a. Num a => a -> a
signum
  negate :: GenHaxl u w a -> GenHaxl u w a
negate      = (a -> a) -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
forall a. Num a => a -> a
negate

instance Fractional a => Fractional (GenHaxl u w a) where
  / :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
(/) = (a -> a -> a) -> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Fractional a => a -> a -> a
(/)
  recip :: GenHaxl u w a -> GenHaxl u w a
recip = (a -> a) -> GenHaxl u w a -> GenHaxl u w a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
forall a. Fractional a => a -> a
recip
  fromRational :: Rational -> GenHaxl u w a
fromRational = a -> GenHaxl u w a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> GenHaxl u w a)
-> (Rational -> a) -> Rational -> GenHaxl u w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> a
forall a. Fractional a => Rational -> a
fromRational

-- -----------------------------------------------------------------------------
-- Convenience functions for avoiding do-notation boilerplate

-- convention is to prefix the name with a '.'.  We could change this,
-- or even just not provide these at all.

(.>) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
.> :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.>) = (a -> a -> Bool)
-> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.>)

(.<) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
.< :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.<) = (a -> a -> Bool)
-> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.<)

(.>=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
.>= :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.>=) = (a -> a -> Bool)
-> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.>=)

(.<=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
.<= :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.<=) = (a -> a -> Bool)
-> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.<=)

(.==) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
.== :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(.==) = (a -> a -> Bool)
-> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(Prelude.==)

(./=) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
./= :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
(./=) = (a -> a -> Bool)
-> GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(Prelude./=)

(.++) :: GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a]
.++ :: GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a]
(.++) = ([a] -> [a] -> [a])
-> GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(Prelude.++)

-- short-circuiting Bool operations
(.&&):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
GenHaxl u w Bool
fa .&& :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
.&& GenHaxl u w Bool
fb = do Bool
a <- GenHaxl u w Bool
fa; if Bool
a then GenHaxl u w Bool
fb else Bool -> GenHaxl u w Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

(.||):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
GenHaxl u w Bool
fa .|| :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
.|| GenHaxl u w Bool
fb = do Bool
a <- GenHaxl u w Bool
fa; if Bool
a then Bool -> GenHaxl u w Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else GenHaxl u w Bool
fb

pair :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (a, b)
pair :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (a, b)
pair = (a -> b -> (a, b))
-> GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)

-- -----------------------------------------------------------------------------
-- Applicative traversals

-- | We don't want the monadic 'mapM', because that doesn't do batching.
-- There doesn't seem to be a way to make 'Data.Traversable.mapM' have
-- the right behaviour when used with Haxl, so instead we define 'mapM'
-- to be 'traverse' in Haxl code.
mapM :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
mapM :: (a -> f b) -> t a -> f (t b)
mapM = (a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse

forM :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)
forM :: t a -> (a -> f b) -> f (t b)
forM = ((a -> f b) -> t a -> f (t b)) -> t a -> (a -> f b) -> f (t b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
mapM

-- | See 'mapM'.
mapM_ :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f ()
mapM_ :: (a -> f b) -> t a -> f ()
mapM_ a -> f b
f t a
t = f (t b) -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f (t b) -> f ()) -> f (t b) -> f ()
forall a b. (a -> b) -> a -> b
$ (a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f t a
t

forM_ :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f ()
forM_ :: t a -> (a -> f b) -> f ()
forM_ = ((a -> f b) -> t a -> f ()) -> t a -> (a -> f b) -> f ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> f b) -> t a -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f ()
mapM_

-- | See 'mapM'.
sequence :: (Traversable t, Applicative f) => t (f a) -> f (t a)
sequence :: t (f a) -> f (t a)
sequence = t (f a) -> f (t a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA

-- | See 'mapM'.
sequence_ :: (Traversable t, Applicative f) => t (f a) -> f ()
sequence_ :: t (f a) -> f ()
sequence_ t (f a)
t = f (t a) -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f (t a) -> f ()) -> f (t a) -> f ()
forall a b. (a -> b) -> a -> b
$ t (f a) -> f (t a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA t (f a)
t

-- | See 'mapM'.
filterM :: (Applicative f) => (a -> f Bool) -> [a] -> f [a]
filterM :: (a -> f Bool) -> [a] -> f [a]
filterM a -> f Bool
predicate [a]
xs =
    [Bool] -> [a]
filt ([Bool] -> [a]) -> f [Bool] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f Bool) -> [a] -> f [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
mapM a -> f Bool
predicate [a]
xs
  where
    filt :: [Bool] -> [a]
filt [Bool]
bools = [ a
x | (a
x,Bool
True) <- [a] -> [Bool] -> [(a, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [Bool]
bools ]

-- | In somes cases, we do want the monadic version of @('>>')@ to disable
-- concurrency and start one computation only after the other finishes, e.g.:
--
-- @
-- deferedFetch x = do
--   sleep 5
--   fetch x  -- fetch will actually run concurrently with sleep
-- @
--
-- But we have defined @('>>') = ('*>')@ with the applicative behavior as this
-- is desired in most cases, so instead we define 'andThen' as the monadic
-- version of @('>>')@:
--
-- @
-- deferedFetch x = sleep 5 `andThen` fetch x
-- @
andThen :: Monad m => m a -> m b -> m b
andThen :: m a -> m b -> m b
andThen m a
a m b
b = m a
a m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> m b
b

--------------------------------------------------------------------------------

-- | Runs the given 'GenHaxl' computation, and if it throws a
-- 'TransientError' or 'LogicError' exception (see
-- "Haxl.Core.Exception"), the exception is ignored and the supplied
-- default value is returned instead.
withDefault :: a -> GenHaxl u w a -> GenHaxl u w a
withDefault :: a -> GenHaxl u w a -> GenHaxl u w a
withDefault a
d GenHaxl u w a
a = GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
forall u w a. GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
catchAny GenHaxl u w a
a (a -> GenHaxl u w a
forall (m :: * -> *) a. Monad m => a -> m a
return a
d)

-- | Catch 'LogicError's and 'TransientError's and perform an alternative action
catchAny
  :: GenHaxl u w a   -- ^ run this first
  -> GenHaxl u w a   -- ^ if it throws 'LogicError' or 'TransientError', run this
  -> GenHaxl u w a
catchAny :: GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w a
catchAny GenHaxl u w a
haxl GenHaxl u w a
handler =
  GenHaxl u w a
haxl GenHaxl u w a -> (SomeException -> GenHaxl u w a) -> GenHaxl u w a
forall e u w a.
Exception e =>
GenHaxl u w a -> (e -> GenHaxl u w a) -> GenHaxl u w a
`catch` \SomeException
e ->
    if Maybe LogicError -> Bool
forall a. Maybe a -> Bool
isJust (SomeException -> Maybe LogicError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe LogicError) Bool -> Bool -> Bool
||
       Maybe TransientError -> Bool
forall a. Maybe a -> Bool
isJust (SomeException -> Maybe TransientError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe TransientError)
      then
        GenHaxl u w a
handler
      else
        SomeException -> GenHaxl u w a
forall e u w a. Exception e => e -> GenHaxl u w a
throw SomeException
e