Cleanup

src/Model/Types.hs

@@ -320,19 +320,16 @@ deriveJSON defaultOptions
   } ''SubmissionMode
 derivePersistFieldJSON ''SubmissionMode
 
-instance PathPiece SubmissionMode where
+finitePathPiece ''SubmissionMode
-  toPathPiece = (Map.fromList (zip universeF verbs) !)
+  [ "no-submissions"
-    where
+  , "no-upload"
-      verbs = [ "no-submissions"
+  , "no-unpack"
-              , "no-upload"
+  , "unpack"
-              , "no-unpack"
+  , "correctors"
-              , "unpack"
+  , "correctors+no-upload"
-              , "correctors"
+  , "correctors+no-unpack"
-              , "correctors+no-upload"
+  , "correctors+unpack"
-              , "correctors+no-unpack"
+  ]
-              , "correctors+unpack"
-              ]
-  fromPathPiece = finiteFromPathPiece
 
 data SubmissionModeDescr = SubmissionModeNone
                          | SubmissionModeCorrector
@@ -342,15 +339,12 @@ data SubmissionModeDescr = SubmissionModeNone
 instance Universe SubmissionModeDescr
 instance Finite SubmissionModeDescr
 
-instance PathPiece SubmissionModeDescr where
+finitePathPiece ''SubmissionModeDescr
-  toPathPiece = (Map.fromList (zip universeF verbs) !)
+  [ "no-submissions"
-    where
+  , "correctors"
-      verbs = [ "no-submissions"
+  , "users"
-              , "correctors"
+  , "correctors+users"
-              , "users"
+  ]
-              , "correctors+users"
-              ]
-  fromPathPiece = finiteFromPathPiece
 
 classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
 classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone

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)
@@ -45,6 +47,16 @@ nullaryPathPiece nullaryType mangle =
       [ 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
   where