Cleanup FormResult-Instances

package.yaml

@@ -116,6 +116,7 @@ dependencies:
   - lifted-base
   - lattices
   - hsass
+  - semigroupoids
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Utils.hs

@@ -85,11 +85,6 @@ getMsgRenderer = do
   return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
 
 
-instance Monad FormResult where
-  FormMissing        >>= _ = FormMissing
-  (FormFailure errs) >>= _ = FormFailure errs
-  (FormSuccess a)    >>= f = f a
-
 guardAuthResult :: MonadHandler m => AuthResult -> m ()
 guardAuthResult AuthenticationRequired = notAuthenticated
 guardAuthResult (Unauthorized t) = permissionDenied t

src/Utils/Form.hs

@@ -3,6 +3,7 @@
 module Utils.Form where
 
 import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
+import Yesod.Core.Instances ()
 import Settings
 
 import Utils.Parameters

src/Yesod/Core/Instances.hs

@@ -4,6 +4,7 @@ module Yesod.Core.Instances
   (
   ) where
 
+import Prelude (errorWithoutStackTrace)
 import ClassyPrelude.Yesod
 
 import Utils (assertM')
@@ -14,6 +15,9 @@ import Data.ByteString.Builder (toLazyByteString)
 import System.FilePath ((</>))
 
 import Data.Aeson
+
+import Control.Monad.Fix
+import Data.Functor.Extend
   
 
 instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
@@ -39,3 +43,22 @@ instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
 
 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
+
+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