{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module defines all missing instances of third party libraries.
module Hasura.Base.Instances () where

import Control.Monad.Fix
import Data.Aeson qualified as J
import Data.Functor.Product (Product (Pair))
import "some" Data.GADT.Compare (GCompare (gcompare), GOrdering (GEQ, GGT, GLT))
import Data.HashMap.Strict qualified as M
import Data.HashSet qualified as S
import Data.OpenApi.Declare as D
import Data.Text qualified as T
import Data.URL.Template qualified as UT
import Database.PG.Query qualified as Q
import Hasura.Prelude
import Language.Haskell.TH.Syntax qualified as TH
import System.Cron.Parser qualified as C
import System.Cron.Types qualified as C
import Text.Regex.TDFA qualified as TDFA
import Text.Regex.TDFA.Pattern qualified as TDFA

--------------------------------------------------------------------------------
-- MonadFix

instance (Monoid d, MonadFix m) => MonadFix (DeclareT d m) where
  mfix :: (a -> DeclareT d m a) -> DeclareT d m a
mfix a -> DeclareT d m a
f = (d -> m (d, a)) -> DeclareT d m a
forall d (m :: * -> *) a. (d -> m (d, a)) -> DeclareT d m a
DeclareT ((d -> m (d, a)) -> DeclareT d m a)
-> (d -> m (d, a)) -> DeclareT d m a
forall a b. (a -> b) -> a -> b
$ \d
s -> ((d, a) -> m (d, a)) -> m (d, a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((d, a) -> m (d, a)) -> m (d, a))
-> ((d, a) -> m (d, a)) -> m (d, a)
forall a b. (a -> b) -> a -> b
$ \ ~(d
_, a
a) -> DeclareT d m a -> d -> m (d, a)
forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT (a -> DeclareT d m a
f a
a) d
s
  {-# INLINE mfix #-}

--------------------------------------------------------------------------------
-- Deepseq

instance NFData UT.Variable

instance NFData UT.TemplateItem

instance NFData UT.URLTemplate

instance NFData C.StepField

instance NFData C.RangeField

instance NFData C.SpecificField

instance NFData C.BaseField

instance NFData C.CronField

instance NFData C.MonthSpec

instance NFData C.DayOfMonthSpec

instance NFData C.DayOfWeekSpec

instance NFData C.HourSpec

instance NFData C.MinuteSpec

instance NFData C.CronSchedule

--------------------------------------------------------------------------------
-- Template Haskell

instance (TH.Lift k, TH.Lift v) => TH.Lift (M.HashMap k v) where
  lift :: HashMap k v -> Q Exp
lift HashMap k v
m = [|M.fromList $(TH.lift $ M.toList m)|]
  liftTyped :: HashMap k v -> Q (TExp (HashMap k v))
liftTyped = Q Exp -> Q (TExp (HashMap k v))
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (HashMap k v)))
-> (HashMap k v -> Q Exp) -> HashMap k v -> Q (TExp (HashMap k v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap k v -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift

instance TH.Lift a => TH.Lift (S.HashSet a) where
  lift :: HashSet a -> Q Exp
lift HashSet a
s = [|S.fromList $(TH.lift $ S.toList s)|]
  liftTyped :: HashSet a -> Q (TExp (HashSet a))
liftTyped = Q Exp -> Q (TExp (HashSet a))
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (HashSet a)))
-> (HashSet a -> Q Exp) -> HashSet a -> Q (TExp (HashSet a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift

deriving instance TH.Lift TDFA.CompOption

deriving instance TH.Lift TDFA.DoPa

deriving instance TH.Lift TDFA.ExecOption

deriving instance TH.Lift TDFA.Pattern

deriving instance TH.Lift TDFA.PatternSet

deriving instance TH.Lift TDFA.PatternSetCharacterClass

deriving instance TH.Lift TDFA.PatternSetCollatingElement

deriving instance TH.Lift TDFA.PatternSetEquivalenceClass

--------------------------------------------------------------------------------
-- GADT

instance (GCompare f, GCompare g) => GCompare (Product f g) where
  Pair f a
a1 g a
a2 gcompare :: Product f g a -> Product f g b -> GOrdering a b
`gcompare` Pair f b
b1 g b
b2 = case f a -> f b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare f a
a1 f b
b1 of
    GOrdering a b
GLT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GLT
    GOrdering a b
GEQ -> case g a -> g b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare g a
a2 g b
b2 of
      GOrdering a b
GLT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GLT
      GOrdering a b
GEQ -> GOrdering a b
forall k (a :: k). GOrdering a a
GEQ
      GOrdering a b
GGT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GGT
    GOrdering a b
GGT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GGT

--------------------------------------------------------------------------------
-- JSON

instance J.FromJSON C.CronSchedule where
  parseJSON :: Value -> Parser CronSchedule
parseJSON = String
-> (Text -> Parser CronSchedule) -> Value -> Parser CronSchedule
forall a. String -> (Text -> Parser a) -> Value -> Parser a
J.withText String
"CronSchedule" ((Text -> Parser CronSchedule) -> Value -> Parser CronSchedule)
-> (Text -> Parser CronSchedule) -> Value -> Parser CronSchedule
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    Either String CronSchedule
-> (String -> Parser CronSchedule) -> Parser CronSchedule
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft (Text -> Either String CronSchedule
C.parseCronSchedule Text
t) String -> Parser CronSchedule
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance J.ToJSON C.CronSchedule where
  toJSON :: CronSchedule -> Value
toJSON = Text -> Value
J.String (Text -> Value) -> (CronSchedule -> Text) -> CronSchedule -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CronSchedule -> Text
C.serializeCronSchedule

instance J.ToJSONKey Void

--------------------------------------------------------------------------------
-- Postgres

instance Q.ToPrepArg C.CronSchedule where
  toPrepVal :: CronSchedule -> PrepArg
toPrepVal = Text -> PrepArg
forall a. ToPrepArg a => a -> PrepArg
Q.toPrepVal (Text -> PrepArg)
-> (CronSchedule -> Text) -> CronSchedule -> PrepArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CronSchedule -> Text
C.serializeCronSchedule

instance Q.FromCol C.CronSchedule where
  fromCol :: Maybe ByteString -> Either Text CronSchedule
fromCol Maybe ByteString
bs =
    case Maybe ByteString -> Either Text Text
forall a. FromCol a => Maybe ByteString -> Either Text a
Q.fromCol Maybe ByteString
bs of
      Left Text
err -> Text -> Either Text CronSchedule
forall a b. a -> Either a b
Left Text
err
      Right Text
dbCron ->
        case Text -> Either String CronSchedule
C.parseCronSchedule Text
dbCron of
          Left String
err' -> Text -> Either Text CronSchedule
forall a b. a -> Either a b
Left (Text -> Either Text CronSchedule)
-> Text -> Either Text CronSchedule
forall a b. (a -> b) -> a -> b
$ Text
"invalid cron schedule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err'
          Right CronSchedule
cron -> CronSchedule -> Either Text CronSchedule
forall a b. b -> Either a b
Right CronSchedule
cron