From 976c50f5deb89ccd1e84a57fd0c13fb9a99c69b1 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 27 Mar 2019 00:23:30 +0100
Subject: [PATCH] Cleanup FormResult-Instances

---
 package.yaml                |  1 +
 src/Utils.hs                |  5 -----
 src/Utils/Form.hs           |  1 +
 src/Yesod/Core/Instances.hs | 23 +++++++++++++++++++++++
 4 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/package.yaml b/package.yaml
index 83b3b006e..339ecff3e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -116,6 +116,7 @@ dependencies:
   - lifted-base
   - lattices
   - hsass
+  - semigroupoids
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/src/Utils.hs b/src/Utils.hs
index 89e0b164d..24631fd2f 100644
--- a/src/Utils.hs
+++ b/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
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 96aa894b6..7efe94bb7 100644
--- a/src/Utils/Form.hs
+++ b/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
diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs
index 0b0f139c4..b5ac9bed8 100644
--- a/src/Yesod/Core/Instances.hs
+++ b/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