{-# 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 System.FilePath ((</>))

import Data.Aeson
import Data.Aeson.Types

import Control.Monad.Fix
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail as MonadFail
import Control.Monad.Except (MonadError(..))
import Data.Functor.Extend

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


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

  fail = MonadFail.fail

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

deriving instance Eq a => Eq (FormResult a)