Fix some hlint

.hlint.yaml

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

hlint/Hlint.hs

@@ -1 +1,4 @@
-{-# OPTIONS_GHC -F -pgmF hlint-test -optF --git -optF -j -optF src #-}
+{-# OPTIONS_GHC
+      -F -pgmF hlint-test
+         -optF src
+  #-}

src/Handler/SystemMessage.hs

@@ -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
+    (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
-    now <- liftIO $ getCurrentTime
+    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")

src/Handler/Term.hs

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

src/Handler/Users.hs

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

src/Handler/Utils.hs

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

src/Handler/Utils/DateTime.hs

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

src/Handler/Utils/Form.hs

@@ -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 LTUUnique{_ltuResult} -> Right _ltuResult
-        (Just (LTUNone _ _))          -> Left MsgIllDefinedUTCTime
+        Just LTUNone{}             -> Left MsgIllDefinedUTCTime
-        (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
+        Just LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
-        Nothing -> Left MsgInvalidDateTimeFormat
+        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)

src/Handler/Utils/Rating.hs

@@ -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 Points{..}     = pretty ( show maxPoints <> " Punkte" :: String)
-  pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String )
+  pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
-  pretty (PassBinary)      = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: 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{..}
 

src/Handler/Utils/StudyFeatures.hs

@@ -37,8 +37,8 @@ pKey :: Parser Int
 pKey = decimal
 
 pType :: Parser StudyFieldType
-pType = FieldPrimary   <$ (try $ string "HF")
+pType = FieldPrimary   <$ try (string "HF")
-    <|> FieldSecondary <$ (try $ string "NF")
+    <|> FieldSecondary <$ try (string "NF")
 
 decimal :: Parser Int
 decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'

src/Handler/Utils/Table.hs

@@ -1,8 +1,7 @@
 module Handler.Utils.Table where
 -- General Utilities for Tables
 
-import Import hiding  ((<>))
+import Import
--- import Data.Monoid ((<>))
 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>

src/Handler/Utils/Table/Cells.hs

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

src/Handler/Utils/Table/Pagination.hs

@@ -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.RWS hiding ((<>), mapM_)
-import Control.Monad.Writer hiding ((<>), mapM_, forM_)
+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}|])

src/Handler/Utils/Zip.hs

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

src/Jobs/Crontab.hs

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

src/Jobs/Handler/SendNotification/SubmissionRated.hs

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

src/Model/Migration.hs

@@ -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 '[]';
         |]

src/Model/Migration/Types.hs

@@ -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 Bonus {..}  = Current.Bonus  Current.Points {..}
-sheetType Normal {..} = Current.Normal $ Current.Points {..}
+sheetType Normal {..} = Current.Normal Current.Points {..}
-sheetType Pass {..}   = Current.Normal $ Current.PassPoints {..}
+sheetType Pass {..}   = Current.Normal Current.PassPoints {..}
 sheetType NotGraded   = Current.NotGraded
 
 {- TODO:

src/Model/Migration/Version.hs

@@ -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
+    quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
-      [x] -> x
+      [x] -> TH.lift x
       []  -> error "No parse"
       _   -> error "Ambiguous parse"
-    quotePat = error "version cannot be used as pattern"
+migrationVersion = undefinedQuote{quoteExp}
-    quoteType = error "version cannot be used as type"
-    quoteDec = error "version cannot be used as declaration"
-migrationVersion = QuasiQuoter{..}
   where
     quoteExp "initial" = TH.lift InitialVersion
-    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+    quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
-      [x] -> MigrationVersion x
+      [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"

src/Settings/Cluster.hs

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

src/Utils/DB.hs

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

src/Utils/Form.hs

@@ -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 =
+fsl lbl
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = []
+                  , fsAttrs    = []
-  }
+                  }
 
 fslI :: RenderMessage site msg => msg -> FieldSettings site
-fslI lbl =
+fslI lbl
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = []
+                  , fsAttrs    = []
-  }
+                  }
 
 fslp ::  Text -> Text -> FieldSettings site
-fslp lbl placeholder =
+fslp lbl placeholder
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
+                  , fsAttrs    = [("placeholder", placeholder)]
-  }
+                  }
 
 fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
-fslpI lbl placeholder =
+fslpI lbl placeholder
-  FieldSettings { fsLabel    = (SomeMessage lbl)
+  = FieldSettings { fsLabel    = SomeMessage lbl
-                , fsTooltip  = Nothing
+                  , fsTooltip  = Nothing
-                , fsId       = Nothing
+                  , fsId       = Nothing
-                , fsName     = Nothing
+                  , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
+                  , 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 [] = [(attr, valu)]
-    newAttrs (p@(a,v):t)
+    newAttrs (p@(a,v) : t)
-      | attr==a   = (a,T.append valu $ cons ' ' v):t
+      | attr==a   = (a, T.append valu $ cons ' ' v) : t
-      | otherwise = p:(newAttrs 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 :: [(Text, Text)] -> [(Text, Text)]
-    newAttrs [] = [(attr,T.intercalate " " valus)]
+    newAttrs [] = [(attr, T.intercalate " " valus)]
-    newAttrs (p@(a,v):t)
+    newAttrs (p@(a,v) : t)
-      | attr==a   = (a,T.intercalate " " (v:valus)):t
+      | attr==a   = ( a, T.intercalate " " $ v : valus ) : t
-      | otherwise = p:(newAttrs 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)

src/Utils/Lang.hs

@@ -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
+  = flip fromMaybe found $ selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
-      Just l' -> l'
-      Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
   | otherwise = selectLanguage' avL ls
 
 langMatches :: Lang -- ^ Needle