SheetType refactoring (Halfway only)

src/Foundation.hs

@@ -882,7 +882,7 @@ defaultLinks = -- Define the menu items of the header.
       , menuItemAccessCallback' = return True
       }
   , NavbarRight $ MenuItem
-      { menuItemLabel = "Einstellungen"
+      { menuItemLabel = "Anpassen"
       , menuItemIcon = Just "cogs"
       , menuItemRoute = ProfileR
       , menuItemModal = False
@@ -917,7 +917,7 @@ defaultLinks = -- Define the menu items of the header.
       , menuItemAccessCallback' = return True
       }
   , NavbarAside $ MenuItem
-      { menuItemLabel = "Korrekturen"
+      { menuItemLabel = "Korrektur"
       , menuItemIcon = Just "check"
       , menuItemRoute = CorrectionsR
       , menuItemModal = False

src/Handler/Sheet.hs

@@ -65,7 +65,7 @@ import Control.Lens
 -- import Utils.Lens
 
 import qualified Data.Text as Text
-import qualified Data.Aeson as Aeson
+--import qualified Data.Aeson as Aeson
 
 import Control.Monad.Random.Class (MonadRandom(..))
 import Utils.Sql

src/Model/Migration.hs

@@ -16,6 +16,7 @@ import Utils (lastMaybe)
 
 import Model
 import Model.Migration.Version
+import qualified Model.Migration.Types as Legacy
 import Data.Map (Map)
 import qualified Data.Map as Map
 
@@ -196,6 +197,11 @@ customMigrations = Map.fromListWith (>>)
           UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|]
+    , whenM (tableExists "sheet") $ do
+        sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |]
+        forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]                
+    )
   ]
 
 

src/Model/Migration/Types.hs

@@ -0,0 +1,17 @@
+module Model.Migration.Types where 
+  
+import qualified Model as Current
+
+data SheetType
+  = Bonus  { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
+  | Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
+  | Pass   { maxPoints, passingPoints :: Current.Points }
+  | NotGraded
+  deriving (Show, Read, Eq)
+
+sheetType :: SheetType -> Current.SheetType
+sheetType = undefined 
+
+
+deriveJSON defaultOptions ''SheetType
+derivePersistFieldJSON ''SheetType

src/Model/Types.hs

@@ -123,24 +123,34 @@ fromPoints = round
 
 instance DisplayAble Points
 
-data SheetType
-  = Bonus  { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
-  | Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben
---  | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift
-  | Pass   { maxPoints, passingPoints :: Points }
+
+data SheetGrading
+  = Points     { maxPoints :: Points }
+  | PassPoints { maxPoints, passingPoints :: Points }
+  | PassBinary 
+  deriving (Eq, Read, Show)
+
+deriveJSON defaultOptions 
+  { constructorTagModifier = intercalate "-" . map toLower . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = TaggedObject "type" "data"  
+  } ''SheetGrading
+derivePersistFieldJSON ''SheetGrading
+
+data SheetType 
+  = Bonus         { grading :: SheetGrading }
+  | Normal        { grading :: SheetGrading }
+  | Informational { grading :: SheetGrading }
   | NotGraded
-  deriving (Show, Read, Eq)
+  deriving (Eq, Read, Show) 
 
-instance DisplayAble SheetType where
-  display (Bonus {..}) = tshow maxPoints <> " Bonuspunkte"
-  display (Normal{..}) = tshow maxPoints <> " Punkte"
-  display (Pass  {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow maxPoints
-  display (NotGraded)  = "Unbewertet"
-
-deriveJSON defaultOptions ''SheetType
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = TaggedObject "type" "data"  
+  } ''SheetType
 derivePersistFieldJSON ''SheetType
 
-makeLenses_ ''SheetType
 
 data SheetTypeSummary = SheetTypeSummary
   { sumBonusPoints  :: Sum Points

src/Utils/Lens.hs

@@ -29,6 +29,10 @@ makeLenses_ ''SheetCorrector
 
 makeLenses_ ''SubmissionGroup
 
+makeLenses_ ''SheetGrading
+
+makeLenses_ ''SheetType
+
 -- makeClassy_ ''Load