{-# OPTIONS_GHC -fno-warn-orphans #-}

module Yesod.Core.Instances
  (
  ) where

import Prelude (errorWithoutStackTrace)
import ClassyPrelude.Yesod

import Utils (assertM')
import Control.Lens

import Data.ByteString.Builder (toLazyByteString)

import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types

import Control.Monad.Fix
import Control.Monad.Except (MonadError(..))
import Data.Functor.Extend

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Control.Monad.Fail

import Utils.PathPiece (camelToPathPiece)

import Network.HTTP.Types.Method.Instances ()


routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
routeFromPathPiece
  = parseRoute
  . over (_2.traverse._2) (fromMaybe "")
  . over _2 queryToQueryText
  . decodePath
  . encodeUtf8

routeToPathPiece :: RenderRoute site => Route site -> Text
routeToPathPiece
  = pack
  . ("/" </>)
  . unpack
  . decodeUtf8
  . toLazyByteString
  . uncurry encodePath
  . over _2 queryTextToQuery
  . over (_2.traverse._2) (assertM' $ not . null)
  . renderRoute


instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
  fromPathPiece = routeFromPathPiece
  toPathPiece = routeToPathPiece

instance ParseRoute site => FromJSON (Route site) where
  parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece

instance RenderRoute site => ToJSON (Route site) where
  toJSON = String . routeToPathPiece

instance ParseRoute site => FromJSONKey (Route site) where
  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece

instance RenderRoute site => ToJSONKey (Route site) where
  toJSONKey = toJSONKeyText routeToPathPiece

instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
  put = Binary.put . toPathPiece
  get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece

instance RenderRoute site => Hashable (Route site) where
  hashWithSalt s = hashWithSalt s . routeToPathPiece


instance Monad FormResult where
  (FormSuccess a)    >>= f = f a
  FormMissing        >>= _ = FormMissing
  (FormFailure errs) >>= _ = FormFailure errs

instance MonadFail FormResult where
  fail _ = FormMissing

instance MonadError [Text] FormResult where
  throwError = FormFailure

  catchError a@(FormSuccess _)    _ = a
  catchError    FormMissing       _ = FormMissing
  catchError   (FormFailure errs) h = h errs

instance MonadPlus FormResult

instance MonadFix FormResult where
  mfix f = let a = f (unSuccess a) in a
    where unSuccess (FormSuccess x) = x
          unSuccess  FormMissing    = errorWithoutStackTrace "mfix FormResult: FormMissing"
          unSuccess (FormFailure _) = errorWithoutStackTrace "mfix FormResult: FormFailure"

instance Extend FormResult where
  duplicated (FormSuccess x)    = FormSuccess $ FormSuccess x
  duplicated  FormMissing       = FormMissing
  duplicated (FormFailure errs) = FormFailure errs


deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece
  , sumEncoding = ObjectWithSingleField
  } ''ErrorResponse

deriving instance Ord ErrorResponse
deriving instance Read ErrorResponse
instance Hashable ErrorResponse