Fix some hlint
This commit is contained in:
Gregor Kleen
parent
9ccc2e3149
commit
e5d3213efb
12
.hlint.yaml
Normal file
12
.hlint.yaml
Normal file
@ -0,0 +1,12 @@
|
||||
# HLint configuration file
|
||||
# https://github.com/ndmitchell/hlint
|
||||
##########################
|
||||
|
||||
- ignore: { name: "Parse error" }
|
||||
- ignore: { name: "Reduce duplication" }
|
||||
- ignore: { name: "Use ||" }
|
||||
|
||||
- arguments:
|
||||
- -XQuasiQuotes
|
||||
- -XTemplateHaskell
|
||||
- -j
|
||||
@ -1 +1,4 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hlint-test -optF --git -optF -j -optF src #-}
|
||||
{-# OPTIONS_GHC
|
||||
-F -pgmF hlint-test
|
||||
-optF src
|
||||
#-}
|
||||
|
||||
@ -72,7 +72,7 @@ postMessageR cID = do
|
||||
|
||||
formResult addTransRes addTranslation
|
||||
|
||||
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of
|
||||
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
|
||||
[BtnDelete'] -> do
|
||||
runDB $ delete tId
|
||||
addMessageI Success MsgSystemMessageDeleteTranslationSuccess
|
||||
@ -111,7 +111,7 @@ postMessageR cID = do
|
||||
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
|
||||
forms <- traverse (const mkForm) $ () <$ guard maySubmit
|
||||
|
||||
defaultLayout $ do
|
||||
defaultLayout $
|
||||
$(widgetFile "system-message")
|
||||
where
|
||||
modifySystemMessage smId SystemMessage{..} = do
|
||||
@ -162,7 +162,7 @@ postMessageListR = do
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
||||
, dbRow
|
||||
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext)
|
||||
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
|
||||
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
|
||||
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
|
||||
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
|
||||
@ -175,12 +175,12 @@ postMessageListR = do
|
||||
]
|
||||
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
|
||||
Just (_, smT) <- lift $ getSystemMessage appLanguages smId
|
||||
return $ DBRow
|
||||
return DBRow
|
||||
{ dbrOutput = (smE, smT)
|
||||
, ..
|
||||
}
|
||||
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
||||
tableForm <- dbTable psValidator $ DBTable
|
||||
tableForm <- dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtColonnade
|
||||
, dbtProj
|
||||
@ -194,8 +194,8 @@ postMessageListR = do
|
||||
, dbtIdent = "messages" :: Text
|
||||
}
|
||||
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
|
||||
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
|
||||
now <- liftIO $ getCurrentTime
|
||||
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
|
||||
now <- liftIO getCurrentTime
|
||||
let actions = Map.fromList
|
||||
[ (SMDelete, pure SMDDelete)
|
||||
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
|
||||
@ -248,5 +248,5 @@ postMessageListR = do
|
||||
addMessageI Success $ MsgSystemMessageAdded cID
|
||||
redirect $ MessageR cID
|
||||
|
||||
defaultLayout $ do
|
||||
defaultLayout $
|
||||
$(widgetFile "system-message-list")
|
||||
|
||||
@ -13,7 +13,7 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
validateTerm :: Term -> [Text]
|
||||
validateTerm (Term{..}) =
|
||||
validateTerm Term{..} =
|
||||
[ msg | (False, msg) <-
|
||||
[ --startOk
|
||||
( termStart `withinTerm` termName
|
||||
@ -68,7 +68,7 @@ getTermShowR = do
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
|
||||
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
textCell $ (bool "" tickmark termActive :: Text)
|
||||
textCell (bool "" tickmark termActive :: Text)
|
||||
, sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
|
||||
cell [whamlet|_{MsgNumCourses numCourses}|]
|
||||
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
@ -96,7 +96,7 @@ getTermShowR = do
|
||||
-- #{termToText termName}
|
||||
-- |]
|
||||
-- ]
|
||||
((), table) <- dbTable def $ DBTable
|
||||
((), table) <- dbTable def DBTable
|
||||
{ dbtSQLQuery = termData
|
||||
, dbtColonnade = colonnadeTerms
|
||||
, dbtProj = return . dbrOutput
|
||||
@ -116,12 +116,12 @@ getTermShowR = do
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "active"
|
||||
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
|
||||
, FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
|
||||
)
|
||||
, ( "course"
|
||||
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
|
||||
[] -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
cshs -> E.exists . E.from $ \course -> do
|
||||
cshs -> E.exists . E.from $ \course ->
|
||||
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
|
||||
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
|
||||
)
|
||||
@ -134,7 +134,7 @@ getTermShowR = do
|
||||
$(widgetFile "terms")
|
||||
|
||||
getTermEditR :: Handler Html
|
||||
getTermEditR = do
|
||||
getTermEditR =
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
termEditHandler Nothing
|
||||
|
||||
@ -162,7 +162,7 @@ termEditHandler term = do
|
||||
-- MIT INTERNATIONALISIERUNG:
|
||||
addMessageI Success $ MsgTermEdited tid
|
||||
redirect TermShowR
|
||||
(FormMissing ) -> return ()
|
||||
FormMissing -> return ()
|
||||
(FormFailure _) -> addMessageI Warning MsgInvalidInput
|
||||
let actionUrl = TermEditR
|
||||
defaultLayout $ do
|
||||
|
||||
@ -69,7 +69,7 @@ getUsersR = do
|
||||
psValidator = def
|
||||
& defaultSorting [("name", SortAsc),("display-name", SortAsc)]
|
||||
|
||||
((), userList) <- dbTable psValidator $ DBTable
|
||||
((), userList) <- dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
, dbtColonnade
|
||||
, dbtProj = return
|
||||
@ -106,7 +106,7 @@ postAdminHijackUserR cID = do
|
||||
otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
|
||||
otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
|
||||
mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
|
||||
when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
|
||||
unless ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
|
||||
permissionDenied "Cannot escalate admin status to additional schools"
|
||||
|
||||
get404 uid
|
||||
|
||||
@ -31,7 +31,7 @@ downloadFiles = do
|
||||
return userDefaultDownloadFiles
|
||||
|
||||
tidFromText :: Text -> Maybe TermId
|
||||
tidFromText = (fmap TermKey) . maybeRight . termFromText
|
||||
tidFromText = fmap TermKey . maybeRight . termFromText
|
||||
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
||||
|
||||
@ -10,7 +10,7 @@ module Handler.Utils.DateTime
|
||||
|
||||
import Import
|
||||
|
||||
import Data.Time.Zones hiding (localTimeToUTCFull)
|
||||
import Data.Time.Zones
|
||||
import qualified Data.Time.Zones as TZ
|
||||
|
||||
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
|
||||
@ -36,7 +36,7 @@ instance HasLocalTime Day where
|
||||
toLocalTime d = LocalTime d midnight
|
||||
|
||||
instance HasLocalTime UTCTime where
|
||||
toLocalTime t = utcToLocalTime t
|
||||
toLocalTime = utcToLocalTime
|
||||
|
||||
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
|
||||
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
|
||||
@ -78,7 +78,7 @@ getDateTimeFormat sel = do
|
||||
|
||||
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
|
||||
-- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
|
||||
validDateTimeFormats _ SelFormatDateTime = Set.fromList $
|
||||
validDateTimeFormats _ SelFormatDateTime = Set.fromList
|
||||
[ DateTimeFormat "%a %d %b %Y %R"
|
||||
, DateTimeFormat "%a %b %d %Y %R"
|
||||
, DateTimeFormat "%A, %d %B %Y %R"
|
||||
@ -95,7 +95,7 @@ validDateTimeFormats _ SelFormatDateTime = Set.fromList $
|
||||
, DateTimeFormat "%Y-%m-%d %T"
|
||||
, DateTimeFormat "%Y-%m-%dT%T"
|
||||
]
|
||||
validDateTimeFormats _ SelFormatDate = Set.fromList $
|
||||
validDateTimeFormats _ SelFormatDate = Set.fromList
|
||||
[ DateTimeFormat "%a %d %b %Y"
|
||||
, DateTimeFormat "%a %b %d %Y"
|
||||
, DateTimeFormat "%A, %d %B %Y"
|
||||
@ -126,7 +126,7 @@ dateTimeFormatOptions sel = do
|
||||
let
|
||||
toOption fmt@DateTimeFormat{..} = do
|
||||
dateTime <- formatTime' unDateTimeFormat now
|
||||
return $ (dateTime, fmt)
|
||||
return (dateTime, fmt)
|
||||
|
||||
optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
|
||||
|
||||
|
||||
@ -131,7 +131,7 @@ buttonForm csrf = do
|
||||
buttonIdent <- newFormIdent
|
||||
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
|
||||
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
|
||||
let widget = do
|
||||
let widget =
|
||||
[whamlet|
|
||||
#{csrf}
|
||||
$forall bView <- btnViews
|
||||
@ -163,16 +163,16 @@ natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMess
|
||||
natFieldI msg = checkBool (>= 0) msg intField
|
||||
|
||||
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
||||
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField
|
||||
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField
|
||||
|
||||
natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
|
||||
natIntField = natField
|
||||
|
||||
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
|
||||
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField
|
||||
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") intField
|
||||
|
||||
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
|
||||
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
|
||||
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
|
||||
|
||||
pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
|
||||
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
|
||||
@ -252,7 +252,7 @@ zipFileField doUnpack = Field{..}
|
||||
| [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
|
||||
| null files = return $ Right Nothing
|
||||
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
|
||||
fieldView fieldId fieldName attrs _ req = do
|
||||
fieldView fieldId fieldName attrs _ req =
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
|
||||
@ -450,7 +450,7 @@ utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
|
||||
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
||||
-- Browser returns LocalTime
|
||||
utcTimeField = Field
|
||||
{ fieldParse = parseHelperGen $ readTime
|
||||
{ fieldParse = parseHelperGen readTime
|
||||
, fieldView = \theId name attrs val isReq -> do
|
||||
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
|
||||
[whamlet|
|
||||
@ -468,10 +468,10 @@ utcTimeField = Field
|
||||
readTime :: Text -> Either UniWorXMessage UTCTime
|
||||
readTime t =
|
||||
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
|
||||
(Just (LTUUnique time _)) -> Right time
|
||||
(Just (LTUNone _ _)) -> Left MsgIllDefinedUTCTime
|
||||
(Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
|
||||
Nothing -> Left MsgInvalidDateTimeFormat
|
||||
Just LTUUnique{_ltuResult} -> Right _ltuResult
|
||||
Just LTUNone{} -> Left MsgIllDefinedUTCTime
|
||||
Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
|
||||
Nothing -> Left MsgInvalidDateTimeFormat
|
||||
|
||||
langField :: Bool -- ^ Only allow values from `appLanguages`
|
||||
-> Field (HandlerT UniWorX IO) Lang
|
||||
@ -547,13 +547,13 @@ apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
-- ^ Pseudo required
|
||||
apreq f fs mx = formToAForm $ do
|
||||
mr <- getMessageRender
|
||||
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx)
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
|
||||
|
||||
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
|
||||
wpreq f fs mx = mFormToWForm $ do
|
||||
mr <- getMessageRender
|
||||
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx)
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
|
||||
|
||||
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
||||
=> Map action (AForm (HandlerT UniWorX IO) a)
|
||||
|
||||
@ -13,7 +13,7 @@ module Handler.Utils.Rating
|
||||
, extractRatings
|
||||
) where
|
||||
|
||||
import Import hiding ((</>))
|
||||
import Import
|
||||
|
||||
|
||||
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
|
||||
@ -56,9 +56,9 @@ instance Pretty x => Pretty (CI x) where
|
||||
|
||||
|
||||
instance Pretty SheetGrading where
|
||||
pretty (Points {..}) = pretty ( (show maxPoints) <> " Punkte" :: String)
|
||||
pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String )
|
||||
pretty (PassBinary) = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
|
||||
pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
|
||||
pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
|
||||
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
|
||||
|
||||
|
||||
data Rating = Rating
|
||||
@ -138,10 +138,10 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
|
||||
in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
|
||||
|
||||
ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
|
||||
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
|
||||
ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
|
||||
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
|
||||
let
|
||||
fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt"
|
||||
fileTitle = "bewertung_" <> Text.unpack (toPathPiece cID) <.> "txt"
|
||||
fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
|
||||
return File{..}
|
||||
|
||||
|
||||
@ -37,8 +37,8 @@ pKey :: Parser Int
|
||||
pKey = decimal
|
||||
|
||||
pType :: Parser StudyFieldType
|
||||
pType = FieldPrimary <$ (try $ string "HF")
|
||||
<|> FieldSecondary <$ (try $ string "NF")
|
||||
pType = FieldPrimary <$ try (string "HF")
|
||||
<|> FieldSecondary <$ try (string "NF")
|
||||
|
||||
decimal :: Parser Int
|
||||
decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
|
||||
|
||||
@ -1,8 +1,7 @@
|
||||
module Handler.Utils.Table where
|
||||
-- General Utilities for Tables
|
||||
|
||||
import Import hiding ((<>))
|
||||
-- import Data.Monoid ((<>))
|
||||
import Import
|
||||
import Data.Profunctor
|
||||
|
||||
import Control.Monad.Except
|
||||
@ -59,11 +58,11 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
||||
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
|
||||
case () of
|
||||
_ | extId `elem` extIds
|
||||
-> Just <$> (lift $ fromExternal extId)
|
||||
-> Just <$> lift (fromExternal extId)
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
view _ name attributes val _ = do
|
||||
view _ name attributes val _ =
|
||||
[whamlet|
|
||||
<label style="display: block">
|
||||
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|
||||
|
||||
@ -63,7 +63,7 @@ courseCellCL (tid,ssh,csh) = anchorCell link name
|
||||
name = citext2widget csh
|
||||
|
||||
courseCell :: IsDBTable m a => Course -> DBCell m a
|
||||
courseCell (Course {..}) = anchorCell link name `mappend` desc
|
||||
courseCell Course{..} = anchorCell link name `mappend` desc
|
||||
where
|
||||
link = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
name = citext2widget courseName
|
||||
@ -90,7 +90,7 @@ submissionCell crse shn sid =
|
||||
csh = crse ^. _3
|
||||
mkCid = encrypt sid
|
||||
mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
|
||||
mkText cid = display2widget cid
|
||||
mkText = display2widget
|
||||
in anchorCellM' mkCid mkRoute mkText
|
||||
|
||||
correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a
|
||||
|
||||
@ -39,8 +39,8 @@ import qualified Network.Wai as Wai
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.RWS hiding ((<>), mapM_, forM_)
|
||||
import Control.Monad.Writer hiding ((<>), mapM_, forM_)
|
||||
import Control.Monad.RWS hiding ((<>), mapM_)
|
||||
import Control.Monad.Writer hiding ((<>), mapM_)
|
||||
import Control.Monad.Reader (ReaderT(..), mapReaderT)
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
@ -92,7 +92,7 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
||||
filterColumn' cont is t = filterColumn' (cont t) is t
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
||||
filterColumn' cont is t = filterColumn' (cont input) is' t
|
||||
filterColumn' cont is = filterColumn' (cont input) is'
|
||||
where
|
||||
(input, ($ []) -> is') = go (mempty, id) is
|
||||
go acc [] = acc
|
||||
@ -261,12 +261,12 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
|
||||
dbCell = iso
|
||||
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
|
||||
(\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
|
||||
(uncurry WidgetCell)
|
||||
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget _ = return . snd
|
||||
dbHandler _ f = return . over _2 f
|
||||
runDBTable act = liftHandlerT act
|
||||
runDBTable = liftHandlerT
|
||||
|
||||
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
||||
mempty = WidgetCell mempty $ return mempty
|
||||
@ -282,7 +282,7 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
|
||||
|
||||
dbCell = iso
|
||||
(\DBCell{..} -> (dbCellAttrs, dbCellContents))
|
||||
(\(attrs, mkWidget) -> DBCell attrs mkWidget)
|
||||
(uncurry DBCell)
|
||||
|
||||
dbWidget _ = return . snd
|
||||
dbHandler _ f = return . over _2 f
|
||||
@ -313,7 +313,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
||||
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||
dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
|
||||
dbHandler _ f form = return $ \csrf -> over _2 f <$> form csrf
|
||||
dbHandler _ f form = return $ fmap (over _2 f) . form
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
|
||||
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
|
||||
@ -328,7 +328,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
|
||||
|
||||
|
||||
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
|
||||
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do
|
||||
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
[ Option t' (t, d) t'
|
||||
@ -350,7 +350,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
|
||||
psResult <- runInputGetResult $ PaginationInput
|
||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||
<*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
||||
<*> iopt intField (wIdent "pagesize")
|
||||
<*> iopt intField (wIdent "page")
|
||||
<*> ireq checkBoxField (wIdent "table-only")
|
||||
@ -459,7 +459,7 @@ cell :: IsDBTable m a => Widget -> DBCell m a
|
||||
cell wgt = dbCell # ([], return wgt)
|
||||
|
||||
textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
|
||||
textCell = cell . toWidget . (pack :: [Char] -> Text) . otoList
|
||||
textCell = cell . toWidget . (pack :: String -> Text) . otoList
|
||||
stringCell = textCell
|
||||
|
||||
i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
@ -491,10 +491,10 @@ anchorCell' :: IsDBTable m a
|
||||
-> (r -> DBCell m a)
|
||||
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
|
||||
|
||||
anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a
|
||||
anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
|
||||
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
|
||||
|
||||
anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
|
||||
anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
|
||||
anchorCellM' xM x2route x2widget = cell $ do
|
||||
x <- xM
|
||||
let route = x2route x
|
||||
@ -523,7 +523,7 @@ getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
|
||||
formCell :: forall r i a. Ord i
|
||||
=> (r -> MForm (HandlerT UniWorX IO) i)
|
||||
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
|
||||
-> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
|
||||
-> (r -> DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
|
||||
formCell genIndex genForm input = FormCell
|
||||
{ formCellAttrs = []
|
||||
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
|
||||
@ -541,7 +541,7 @@ dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ db
|
||||
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
|
||||
=> Setter' a Bool
|
||||
-> (r -> MForm (HandlerT UniWorX IO) i)
|
||||
-> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
|
||||
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
|
||||
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
|
||||
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
|
||||
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|
||||
|
||||
@ -81,7 +81,7 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
|
||||
}
|
||||
|
||||
toZipData :: Monad m => File -> (ZipEntry, ZipData m)
|
||||
toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
|
||||
toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
|
||||
|
||||
toZipEntry :: File -> ZipEntry
|
||||
toZipEntry File{..} = ZipEntry
|
||||
|
||||
@ -92,7 +92,7 @@ determineCrontab = execWriterT $ do
|
||||
collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
|
||||
collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
|
||||
where
|
||||
procCorrector :: Entity Submission -> (UserId , (Max (Maybe UTCTime)))
|
||||
procCorrector :: Entity Submission -> (UserId ,Max (Maybe UTCTime))
|
||||
procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal
|
||||
<*> Max . submissionRatingAssigned . entityVal
|
||||
|
||||
|
||||
@ -42,7 +42,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
|
||||
, "submission-rating-comment" Aeson..= submissionRatingComment
|
||||
, "submission-rating-time" Aeson..= submissionRatingTime
|
||||
, "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
|
||||
, "submission-rating-passed" Aeson..= (join $ gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints)
|
||||
, "submission-rating-passed" Aeson..= join (gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints)
|
||||
, "sheet-name" Aeson..= sheetName
|
||||
, "sheet-type" Aeson..= sheetType
|
||||
, "course-name" Aeson..= courseName
|
||||
|
||||
@ -165,16 +165,16 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
|
||||
Just name -> update uid [UserSurname =. name]
|
||||
_other -> error $ "Empty userDisplayName found"
|
||||
_other -> error "Empty userDisplayName found"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
||||
, whenM (tableExists "sheet") $ do
|
||||
, whenM (tableExists "sheet") $
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
|
||||
, whenM (columnExists "user" "plugin") $ do
|
||||
, whenM (columnExists "user" "plugin") $
|
||||
-- <> is standard sql for /=
|
||||
[executeQQ|
|
||||
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
|
||||
@ -183,7 +183,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
|
||||
, whenM (tableExists "user") $ do
|
||||
, whenM (tableExists "user") $
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]';
|
||||
|]
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Model.Migration.Types where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
|
||||
import ClassyPrelude.Yesod
|
||||
import Data.Aeson.TH (deriveJSON, defaultOptions)
|
||||
import Database.Persist.Sql
|
||||
|
||||
@ -15,9 +15,9 @@ data SheetType
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
sheetType :: SheetType -> Current.SheetType
|
||||
sheetType Bonus {..} = Current.Bonus $ Current.Points {..}
|
||||
sheetType Normal {..} = Current.Normal $ Current.Points {..}
|
||||
sheetType Pass {..} = Current.Normal $ Current.PassPoints {..}
|
||||
sheetType Bonus {..} = Current.Bonus Current.Points {..}
|
||||
sheetType Normal {..} = Current.Normal Current.Points {..}
|
||||
sheetType Pass {..} = Current.Normal Current.PassPoints {..}
|
||||
sheetType NotGraded = Current.NotGraded
|
||||
|
||||
{- TODO:
|
||||
|
||||
@ -64,22 +64,25 @@ instance PersistFieldSql Version where
|
||||
|
||||
|
||||
version, migrationVersion :: QuasiQuoter
|
||||
version = QuasiQuoter{..}
|
||||
version = undefinedQuote{quoteExp}
|
||||
where
|
||||
quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
|
||||
[x] -> x
|
||||
quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
|
||||
[x] -> TH.lift x
|
||||
[] -> error "No parse"
|
||||
_ -> error "Ambiguous parse"
|
||||
quotePat = error "version cannot be used as pattern"
|
||||
quoteType = error "version cannot be used as type"
|
||||
quoteDec = error "version cannot be used as declaration"
|
||||
migrationVersion = QuasiQuoter{..}
|
||||
migrationVersion = undefinedQuote{quoteExp}
|
||||
where
|
||||
quoteExp "initial" = TH.lift InitialVersion
|
||||
quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
|
||||
[x] -> MigrationVersion x
|
||||
quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
|
||||
[x] -> TH.lift $ MigrationVersion x
|
||||
[] -> error "No parse"
|
||||
_ -> error "Ambiguous parse"
|
||||
|
||||
|
||||
undefinedQuote :: QuasiQuoter
|
||||
undefinedQuote = QuasiQuoter{..}
|
||||
where
|
||||
quoteExp = error "version cannot be used as expression"
|
||||
quotePat = error "version cannot be used as pattern"
|
||||
quoteType = error "version cannot be used as type"
|
||||
quoteDec = error "version cannot be used as declaration"
|
||||
|
||||
@ -114,7 +114,7 @@ instance FromJSON ClientSession.Key where
|
||||
|
||||
instance ClusterSetting 'ClusterErrorMessageKey where
|
||||
type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
|
||||
initClusterSetting _ = liftIO $ SecretBox.newKey
|
||||
initClusterSetting _ = liftIO SecretBox.newKey
|
||||
knownClusterSetting _ = ClusterErrorMessageKey
|
||||
|
||||
instance ToJSON SecretBox.Key where
|
||||
|
||||
@ -24,11 +24,11 @@ entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal ent
|
||||
|
||||
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m (Maybe (Key record))
|
||||
getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
||||
getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
||||
|
||||
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m (Key record)
|
||||
getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
|
||||
getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
|
||||
|
||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
|
||||
@ -31,7 +31,7 @@ data FormLayout = FormStandard
|
||||
|
||||
renderAForm :: Monad m => FormLayout -> FormRender m a
|
||||
renderAForm formLayout aform fragment = do
|
||||
(res, (($ []) -> views)) <- aFormToForm aform
|
||||
(res, ($ []) -> views) <- aFormToForm aform
|
||||
let widget = $(widgetFile "widgets/form")
|
||||
return (res, widget)
|
||||
|
||||
@ -40,58 +40,58 @@ renderAForm formLayout aform fragment = do
|
||||
--------------------
|
||||
|
||||
fsl :: Text -> FieldSettings site
|
||||
fsl lbl =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
fsl lbl
|
||||
= FieldSettings { fsLabel = SomeMessage lbl
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
|
||||
fslI :: RenderMessage site msg => msg -> FieldSettings site
|
||||
fslI lbl =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
fslI lbl
|
||||
= FieldSettings { fsLabel = SomeMessage lbl
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
|
||||
fslp :: Text -> Text -> FieldSettings site
|
||||
fslp lbl placeholder =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
fslp lbl placeholder
|
||||
= FieldSettings { fsLabel = SomeMessage lbl
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
|
||||
fslpI lbl placeholder =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
fslpI lbl placeholder
|
||||
= FieldSettings { fsLabel = SomeMessage lbl
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
||||
addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
|
||||
where
|
||||
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
||||
newAttrs [] = [(attr,valu)]
|
||||
newAttrs (p@(a,v):t)
|
||||
| attr==a = (a,T.append valu $ cons ' ' v):t
|
||||
| otherwise = p:(newAttrs t)
|
||||
newAttrs [] = [(attr, valu)]
|
||||
newAttrs (p@(a,v) : t)
|
||||
| attr==a = (a, T.append valu $ cons ' ' v) : t
|
||||
| otherwise = p : newAttrs t
|
||||
|
||||
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
|
||||
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
||||
addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
|
||||
where
|
||||
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
||||
newAttrs [] = [(attr,T.intercalate " " valus)]
|
||||
newAttrs (p@(a,v):t)
|
||||
| attr==a = (a,T.intercalate " " (v:valus)):t
|
||||
| otherwise = p:(newAttrs t)
|
||||
newAttrs :: [(Text, Text)] -> [(Text, Text)]
|
||||
newAttrs [] = [(attr, T.intercalate " " valus)]
|
||||
newAttrs (p@(a,v) : t)
|
||||
| attr==a = ( a, T.intercalate " " $ v : valus ) : t
|
||||
| otherwise = p : newAttrs t
|
||||
|
||||
addClass :: Text -> FieldSettings site -> FieldSettings site
|
||||
addClass = addAttr "class"
|
||||
@ -103,17 +103,19 @@ addName :: Text -> FieldSettings site -> FieldSettings site
|
||||
addName nm fs = fs { fsName = Just nm }
|
||||
|
||||
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
|
||||
|
||||
addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
addIdClass gId gClass fs = fs { fsId = Just gId, fsAttrs = ("class",gClass) : fsAttrs fs }
|
||||
|
||||
|
||||
setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
|
||||
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
|
||||
setClass fs c = fs { fsAttrs = ("class",c) : fsAttrs fs }
|
||||
|
||||
setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
|
||||
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
setNameClass fs gName gClass = fs { fsName = Just gName
|
||||
, fsAttrs = ("class",gClass) : fsAttrs fs
|
||||
}
|
||||
|
||||
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
|
||||
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
|
||||
@ -179,7 +181,7 @@ identForm = identifyForm . toPathPiece
|
||||
data family ButtonCssClass site :: *
|
||||
|
||||
bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
|
||||
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
|
||||
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc))
|
||||
|
||||
class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
|
||||
label :: a -> WidgetT site IO ()
|
||||
@ -213,7 +215,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
||||
fieldParse _ _ = return $ Left "Multiple button values"
|
||||
|
||||
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
|
||||
combinedButtonField btns = traverse b2f btns
|
||||
combinedButtonField = traverse b2f
|
||||
where
|
||||
b2f b = aopt (buttonField b) "" Nothing
|
||||
|
||||
@ -247,7 +249,7 @@ reorderField optList = Field{..}
|
||||
olNum = fromIntegral $ length olOptions
|
||||
selOptions = Map.fromList $ do
|
||||
i <- [1..olNum]
|
||||
(readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
|
||||
(readMay -> Just (n :: Word), '.' : extVal) <- break (== '.') . unpack <$> optlist
|
||||
guard $ i == n
|
||||
Just val <- return . olReadExternal $ pack extVal
|
||||
return (i, val)
|
||||
|
||||
@ -24,9 +24,7 @@ selectLanguage' avL (l:ls)
|
||||
| not $ null l
|
||||
, Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l
|
||||
, found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL
|
||||
= case found of
|
||||
Just l' -> l'
|
||||
Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
|
||||
= flip fromMaybe found $ selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
|
||||
| otherwise = selectLanguage' avL ls
|
||||
|
||||
langMatches :: Lang -- ^ Needle
|
||||
|
||||
Loading…
Reference in New Issue
Block a user