From 816ce0595e2636d98f2c347828e05ad92e029841 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 24 Apr 2019 15:13:06 +0200
Subject: [PATCH] Cleanup

---
 src/Model/Types.hs     | 38 ++++++++++++++++----------------------
 src/Utils/PathPiece.hs | 14 +++++++++++++-
 2 files changed, 29 insertions(+), 23 deletions(-)

diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index c690483a2..575d86403 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -320,19 +320,16 @@ deriveJSON defaultOptions
   } ''SubmissionMode
 derivePersistFieldJSON ''SubmissionMode
 
-instance PathPiece SubmissionMode where
-  toPathPiece = (Map.fromList (zip universeF verbs) !)
-    where
-      verbs = [ "no-submissions"
-              , "no-upload"
-              , "no-unpack"
-              , "unpack"
-              , "correctors"
-              , "correctors+no-upload"
-              , "correctors+no-unpack"
-              , "correctors+unpack"
-              ]
-  fromPathPiece = finiteFromPathPiece
+finitePathPiece ''SubmissionMode
+  [ "no-submissions"
+  , "no-upload"
+  , "no-unpack"
+  , "unpack"
+  , "correctors"
+  , "correctors+no-upload"
+  , "correctors+no-unpack"
+  , "correctors+unpack"
+  ]
 
 data SubmissionModeDescr = SubmissionModeNone
                          | SubmissionModeCorrector
@@ -342,15 +339,12 @@ data SubmissionModeDescr = SubmissionModeNone
 instance Universe SubmissionModeDescr
 instance Finite SubmissionModeDescr
 
-instance PathPiece SubmissionModeDescr where
-  toPathPiece = (Map.fromList (zip universeF verbs) !)
-    where
-      verbs = [ "no-submissions"
-              , "correctors"
-              , "users"
-              , "correctors+users"
-              ]
-  fromPathPiece = finiteFromPathPiece
+finitePathPiece ''SubmissionModeDescr
+  [ "no-submissions"
+  , "correctors"
+  , "users"
+  , "correctors+users"
+  ]
 
 classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
 classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs
index 7a391bc01..334133695 100644
--- a/src/Utils/PathPiece.hs
+++ b/src/Utils/PathPiece.hs
@@ -1,7 +1,7 @@
 module Utils.PathPiece
   ( finiteFromPathPiece
   , nullaryToPathPiece
-  , nullaryPathPiece
+  , nullaryPathPiece, finitePathPiece
   , splitCamel
   , camelToPathPiece, camelToPathPiece'
   , tuplePathPiece
@@ -16,6 +16,8 @@ import Data.Universe
 import qualified Data.Text as Text
 import qualified Data.Char as Char
 
+import qualified Data.Map as Map
+
 import Numeric.Natural
 
 import Data.List (foldl)
@@ -44,6 +46,16 @@ nullaryPathPiece nullaryType mangle =
     , funD 'fromPathPiece
       [ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
     ]
+
+finitePathPiece :: Name -> [Text] -> DecsQ
+finitePathPiece finiteType verbs =
+  pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
+    [ funD 'toPathPiece
+      [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
+    , funD 'fromPathPiece
+      [ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ]
+    ]
+  
   
 splitCamel :: Textual t => t -> [t]
 splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList