106 lines
3.0 KiB
Haskell
106 lines
3.0 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 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)
|