80 lines
2.1 KiB
Haskell
80 lines
2.1 KiB
Haskell
{-# 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 Control.Monad.Fix
|
|
import Control.Monad.Fail (MonadFail)
|
|
import qualified Control.Monad.Fail as MonadFail
|
|
import Control.Monad.Except (MonadError(..))
|
|
import Data.Functor.Extend
|
|
|
|
|
|
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
|
|
fromPathPiece
|
|
= parseRoute
|
|
. over (_2.traverse._2) (fromMaybe "")
|
|
. over _2 queryToQueryText
|
|
. decodePath
|
|
. encodeUtf8
|
|
toPathPiece
|
|
= pack
|
|
. ("/" </>)
|
|
. unpack
|
|
. decodeUtf8
|
|
. toLazyByteString
|
|
. uncurry encodePath
|
|
. over _2 queryTextToQuery
|
|
. over (_2.traverse._2) (assertM' $ not . null)
|
|
. renderRoute
|
|
|
|
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
|
|
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
|
|
|
|
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
|
|
toJSON = String . toPathPiece
|
|
|
|
|
|
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
|