diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 91867c39c..a52f429d8 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -79,7 +79,7 @@ formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> p -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str -- Restricted type for safety formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> m Text -formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj) +formatTime proj t = flip formatTime' t . unDateTimeFormat =<< getDateTimeFormat proj -- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text -- formatTimeH = formatTime diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 15c554a17..2c0ff5949 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -277,7 +277,7 @@ multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf , Just (mr -> optionDisplay) <- actMessage act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd | otherwise - = flip const + = const id return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index d642522c8..582e4193f 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -307,7 +307,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR sentShape <- runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece shapeName) <$> MaybeT askFiles - MaybeT $ either (const Nothing) id <$> lift (fieldParse shapeField ts fs) + MaybeT $ preview (_Right . _Just) <$> lift (fieldParse shapeField ts fs) sentShape' <- if | Just s <- sentShape -> return s | Just iS <- initialShape -> return iS diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 84c19ba6b..140345aff 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -331,7 +331,7 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t bucket <- Concurrent.newTokenBucket atomically $ do hm <- readTVar memcachedLimit - let hm' = HashMap.insertWith (flip const) lK bucket hm + let hm' = HashMap.insertWith (const id) lK bucket hm writeTVar memcachedLimit $! hm' return $ HashMap.lookupDefault (error "could not insert new token bucket") lK hm' sufficientTokens <- liftIO $ Concurrent.tokenBucketTryAlloc bucket burst rate tokens diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8b10d2e3e..3913263cd 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -58,6 +58,8 @@ import Data.Monoid (Endo(..)) import Network.URI (URI, parseURI, uriToString) +import Data.Either (fromRight) + -------------------- -- Field Settings -- @@ -532,7 +534,7 @@ reorderField optList = Field{..} fieldView theId name attrs val isReq = do OptionList{..} <- liftHandler optList let - isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue + isSel n = (==) (fromRight (map optionInternalValue olOptions) val !! pred n) . optionInternalValue nums = map (id &&& withNum theId) [1..length olOptions] withNum t n = tshow n <> "." <> t $(widgetFile "widgets/permutation/permutation") diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index dcc6d8c95..fd2e7abd3 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -20,6 +20,8 @@ import Data.Universe import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Lens + data GlobalGetParam = GetLang | GetReferer @@ -58,7 +60,7 @@ globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe globalGetParamField ident Field{fieldParse} = runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles - MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs) + MaybeT $ preview (_Right . _Just) <$> lift (fieldParse ts fs) data GlobalPostParam = PostFormIdentifier | PostDeleteTarget @@ -97,13 +99,13 @@ globalPostParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Mayb globalPostParamField ident Field{fieldParse} = runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles - MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs) + MaybeT $ preview (_Right . _Just) <$> lift (fieldParse ts fs) globalPostParamFields :: Monad m => GlobalPostParam -> Field m a -> MForm m [a] globalPostParamFields ident Field{fieldParse} = fmap (fromMaybe []) . runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles - forM ((Left <$> fs) ++ (Right <$> ts)) $ \inp -> MaybeT $ either (const Nothing) id <$> lift (either (\f -> fieldParse [] [f]) (\t -> fieldParse [t] []) inp) + forM ((Left <$> fs) ++ (Right <$> ts)) $ \inp -> MaybeT $ preview (_Right . _Just) <$> lift (either (\f -> fieldParse [] [f]) (\t -> fieldParse [t] []) inp) withGlobalPostParam :: PathPiece result => GlobalPostParam -> result -> (Html -> MForm m a) -> (Html -> MForm m a) withGlobalPostParam (toPathPiece -> ident) (toPathPiece -> res) f csrf diff --git a/stack.yaml b/stack.yaml index 88848a6c3..4bdc468ee 100644 --- a/stack.yaml +++ b/stack.yaml @@ -77,6 +77,8 @@ extra-deps: - tz-0.1.3.5@sha256:fb17ca50a7d943e511c0ca70342dc83f66aa2532de2745632f1f5f9b1ad783c4,5086 - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 + - hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 + - network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 resolver: nightly-2021-01-11 compiler: ghc-8.10.3 diff --git a/stack.yaml.lock b/stack.yaml.lock index 556878303..12d6fa671 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -338,6 +338,20 @@ packages: sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 original: hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 +- completed: + hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 + pantry-tree: + size: 442 + sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea + original: + hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 +- completed: + hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 + pantry-tree: + size: 915 + sha256: 97b797944cf068eb5fde620e005e253818f03068b2c20e9cfdd3aaa6cafcb678 + original: + hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 snapshots: - completed: size: 562265