fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2018-08-16 13:00:03 +02:00
parent ceb1191a28
commit 7686996214
2 changed files with 59 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
src/Data/CaseInsensitive/Instances.hs Normal file
View File

@ -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

56
src/Model/Types.hs
View File

@ -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