diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs new file mode 100644 index 000000000..ea5253f44 --- /dev/null +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 21d89735e..f84c0cde0 100644 --- a/src/Model/Types.hs +++ b/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 = - 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) +partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs 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