Cleanup

src/Data/CaseInsensitive/Instances.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.CaseInsensitive.Instances
+  () where
+
+import ClassyPrelude.Yesod
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Database.Persist.Sql
+
+import Text.Blaze (ToMarkup(..))
+
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+
+
+instance PersistField (CI Text) where
+  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
+  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
+  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
+
+instance PersistField (CI String) where
+  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
+  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
+  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
+  
+instance PersistFieldSql (CI Text) where
+  sqlType _ = SqlOther "citext"
+
+instance PersistFieldSql (CI String) where
+  sqlType _ = SqlOther "citext"
+
+instance ToJSON a => ToJSON (CI a) where
+  toJSON = toJSON . CI.original
+
+instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
+  parseJSON = fmap CI.mk . parseJSON
+
+instance ToMessage a => ToMessage (CI a) where
+  toMessage = toMessage . CI.original
+
+instance ToMarkup a => ToMarkup (CI a) where
+  toMarkup = toMarkup . CI.original
+  preEscapedToMarkup = preEscapedToMarkup . CI.original
+
+instance ToWidget site a => ToWidget site (CI a) where
+  toWidget = toWidget . CI.original
+
+instance RenderMessage site a => RenderMessage site (CI a) where
+  renderMessage f ls msg = renderMessage f ls $ CI.original msg

src/Model/Types.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Model.Types where
 
@@ -18,6 +17,7 @@ import Control.Lens
 
 import Data.Set (Set)
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Data.Fixed
 import Data.Monoid (Sum(..))
 import Data.Maybe (fromJust)
@@ -35,11 +35,11 @@ import Web.HttpApiData
 
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lens as Text
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
 import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
@@ -49,10 +49,6 @@ import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
 import Data.Typeable (Typeable)
 
-import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
-import Text.Blaze (ToMarkup(..))
-import Yesod.Core.Widget (ToWidget(..))
-
 
 type Points = Centi
 
@@ -135,18 +131,7 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
 -- partitionFileType' = groupMap
 
 partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
-partitionFileType fts =
+partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
-    let (se,sh,ss,sm) = foldl' switchft (Set.empty,Set.empty,Set.empty,Set.empty) fts
-    in \case  SheetExercise -> se
-              SheetHint     -> sh
-              SheetSolution -> ss
-              SheetMarking  -> sm
-  where
-    switchft :: Ord a => (Set a, Set a, Set a, Set a) -> (SheetFileType,a) -> (Set a, Set a, Set a, Set a)
-    switchft (se,sh,ss,sm) (SheetExercise,x) = (Set.insert x se, sh, ss, sm)
-    switchft (se,sh,ss,sm) (SheetHint    ,x) = (se, Set.insert x sh, ss, sm)
-    switchft (se,sh,ss,sm) (SheetSolution,x) = (se, sh, Set.insert x ss, sm)
-    switchft (se,sh,ss,sm) (SheetMarking ,x) = (se, sh, ss, Set.insert x sm)
 
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
@@ -364,41 +349,6 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
 
-instance PersistField (CI Text) where
-  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
-  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
-  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
-
-instance PersistField (CI String) where
-  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
-  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
-  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
-  
-instance PersistFieldSql (CI Text) where
-  sqlType _ = SqlOther "citext"
-
-instance PersistFieldSql (CI String) where
-  sqlType _ = SqlOther "citext"
-
-instance ToJSON a => ToJSON (CI a) where
-  toJSON = toJSON . CI.original
-
-instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
-  parseJSON = fmap CI.mk . parseJSON
-
-instance ToMessage a => ToMessage (CI a) where
-  toMessage = toMessage . CI.original
-
-instance ToMarkup a => ToMarkup (CI a) where
-  toMarkup = toMarkup . CI.original
-  preEscapedToMarkup = preEscapedToMarkup . CI.original
-
-instance ToWidget site a => ToWidget site (CI a) where
-  toWidget = toWidget . CI.original
-
-instance RenderMessage site a => RenderMessage site (CI a) where
-  renderMessage f ls msg = renderMessage f ls $ CI.original msg
-
 -- Type synonyms
 
 type SheetName = CI Text