479 lines
14 KiB
Haskell
479 lines
14 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
|
|
|
|
module Utils
|
|
( module Utils
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (foldlM)
|
|
|
|
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
|
|
import qualified Data.Foldable as Fold
|
|
import Data.Foldable as Utils (foldlM, foldrM)
|
|
import Data.Monoid (Sum(..))
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import Utils.DB as Utils
|
|
import Utils.TH as Utils
|
|
import Utils.DateTime as Utils
|
|
import Utils.PathPiece as Utils
|
|
import Utils.Message as Utils
|
|
import Utils.Lang as Utils
|
|
import Control.Lens as Utils (none)
|
|
|
|
|
|
import Text.Blaze (Markup, ToMarkup)
|
|
|
|
import Data.Char (isDigit)
|
|
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
|
|
import Numeric (showFFloat)
|
|
|
|
import Control.Lens
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
-- import qualified Data.List as List
|
|
|
|
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
|
import Control.Monad.Catch
|
|
|
|
|
|
import qualified Database.Esqueleto as E (Value, unValue)
|
|
|
|
import Language.Haskell.TH
|
|
import Instances.TH.Lift ()
|
|
|
|
import Text.Shakespeare.Text (st)
|
|
|
|
import qualified Data.Aeson as Aeson
|
|
|
|
|
|
|
|
-----------
|
|
-- Yesod --
|
|
-----------
|
|
|
|
newtype MsgRendererS site = MsgRenderer { render :: forall msg. RenderMessage site msg => msg -> Text }
|
|
|
|
getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
|
|
getMsgRenderer = do
|
|
mr <- getMessageRender
|
|
return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
|
|
|
|
|
|
instance Monad FormResult where
|
|
FormMissing >>= _ = FormMissing
|
|
(FormFailure errs) >>= _ = FormFailure errs
|
|
(FormSuccess a) >>= f = f a
|
|
|
|
guardAuthResult :: MonadHandler m => AuthResult -> m ()
|
|
guardAuthResult AuthenticationRequired = notAuthenticated
|
|
guardAuthResult (Unauthorized t) = permissionDenied t
|
|
guardAuthResult Authorized = return ()
|
|
|
|
data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
|
|
deriving (Eq, Ord, Typeable, Show)
|
|
instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
|
|
|
|
unsupportedAuthPredicate :: ExpQ
|
|
unsupportedAuthPredicate = do
|
|
logFunc <- logErrorS
|
|
[e| \tag route -> do
|
|
$(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
|
|
unauthorizedI (UnsupportedAuthPredicate tag route)
|
|
|]
|
|
|
|
|
|
|
|
---------------------
|
|
-- Text and String --
|
|
---------------------
|
|
|
|
tickmark :: IsString a => a
|
|
tickmark = fromString "✔"
|
|
-- Avoid annoying warnings:
|
|
tickmarkS :: String
|
|
tickmarkS = tickmark
|
|
tickmarkT :: Text
|
|
tickmarkT = tickmark
|
|
|
|
text2Html :: Text -> Html
|
|
text2Html = toHtml -- prevents ambiguous types
|
|
|
|
toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
|
|
=> a -> WidgetT site m ()
|
|
toWgt = toWidget . toHtml
|
|
|
|
-- Convenience Functions to avoid type signatures:
|
|
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
|
|
=> Text -> WidgetT site m ()
|
|
text2widget t = [whamlet|#{t}|]
|
|
|
|
citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
|
|
=> CI Text -> WidgetT site m ()
|
|
citext2widget t = [whamlet|#{CI.original t}|]
|
|
|
|
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m)
|
|
=> String -> WidgetT site m ()
|
|
str2widget s = [whamlet|#{s}|]
|
|
|
|
display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a)
|
|
=> a -> WidgetT site m ()
|
|
display2widget = text2widget . display
|
|
|
|
withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
|
|
withFragment form html = flip fmap form $ over _2 (toWidget html >>)
|
|
|
|
|
|
-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
|
|
{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
|
|
class DisplayAble a where
|
|
display :: a -> Text
|
|
-- Default definitions for types belonging to Show (allows empty instance declarations)
|
|
default display :: Show a => a -> Text
|
|
display = pack . show
|
|
|
|
instance DisplayAble Text where
|
|
display = id
|
|
|
|
instance DisplayAble String where
|
|
display = pack
|
|
|
|
instance DisplayAble Int
|
|
instance DisplayAble Int64
|
|
instance DisplayAble Integer
|
|
|
|
instance DisplayAble Rational where
|
|
display r = showFFloat (Just 2) (rat2float r) ""
|
|
& pack
|
|
& dropWhileEnd ('0'==)
|
|
& dropWhileEnd ('.'==)
|
|
where
|
|
rat2float :: Rational -> Double
|
|
rat2float = fromRational
|
|
|
|
instance DisplayAble a => DisplayAble (Maybe a) where
|
|
display Nothing = ""
|
|
display (Just x) = display x
|
|
|
|
instance DisplayAble a => DisplayAble (E.Value a) where
|
|
display = display . E.unValue
|
|
|
|
instance DisplayAble a => DisplayAble (CI a) where
|
|
display = display . CI.original
|
|
|
|
{- We do not want DisplayAble for every Show-Class:
|
|
We want to explicitly verify that the resulting text can be displayed to the User!
|
|
For example: UTCTime values were shown without proper format rendering!
|
|
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
|
|
display = pack . show
|
|
-}
|
|
|
|
textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
|
|
textPercent x = lz <> pack (show rx) <> "%"
|
|
where
|
|
round' :: Double -> Int -- avoids annoying warning
|
|
round' = round
|
|
rx :: Double
|
|
rx = fromIntegral (round' $ 1000.0*x) / 10.0
|
|
lz = if rx < 10.0 then "0" else ""
|
|
|
|
stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
|
|
stepTextCounterCI = CI.map stepTextCounter
|
|
|
|
stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
|
|
stepTextCounter text
|
|
| (Just i) <- readMay number =
|
|
let iplus1 = tshow (succ i :: Int)
|
|
zeroip = justifyRight (length number) '0' iplus1
|
|
in prefix <> zeroip <> suffix
|
|
| otherwise = text
|
|
where -- no splitWhile nor findEnd in Data.Text
|
|
suffix = takeWhileEnd (not . isDigit) text
|
|
number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
|
|
prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
|
|
|
|
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
|
|
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
|
|
|
|
------------
|
|
-- Tuples --
|
|
------------
|
|
|
|
fst3 :: (a,b,c) -> a
|
|
fst3 (x,_,_) = x
|
|
snd3 :: (a,b,c) -> b
|
|
snd3 (_,y,_) = y
|
|
trd3 :: (a,b,c) -> c
|
|
trd3 (_,_,z) = z
|
|
|
|
-- Further projections are available via TemplateHaskell, defined in Utils.Common:
|
|
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
|
|
-- snd3 = $(projNI 3 2)
|
|
|
|
|
|
|
|
-----------
|
|
-- Lists --
|
|
-----------
|
|
|
|
-- notNull = not . null
|
|
|
|
lastMaybe :: [a] -> Maybe a
|
|
lastMaybe [] = Nothing
|
|
lastMaybe [h] = Just h
|
|
lastMaybe (_:t) = lastMaybe t
|
|
|
|
lastMaybe' :: [a] -> Maybe a
|
|
lastMaybe' l = fmap snd $ l ^? _Snoc
|
|
|
|
|
|
mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
|
|
mergeAttrs = mergeAttrs' `on` sort
|
|
where
|
|
special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
|
|
]
|
|
|
|
mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
|
|
| Just merge <- lookup n1 special
|
|
, n2 == n1
|
|
= mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
|
|
| Just _ <- lookup n1 special
|
|
, n1 < n2
|
|
= x2 : mergeAttrs' (x1:xs1) xs2
|
|
| otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
|
|
mergeAttrs' [] xs2 = xs2
|
|
mergeAttrs' xs1 [] = xs1
|
|
|
|
|
|
|
|
----------
|
|
-- Maps --
|
|
----------
|
|
|
|
infixl 5 !!!
|
|
|
|
|
|
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
|
|
(!!!) m k = fromMaybe mempty $ Map.lookup k m
|
|
|
|
groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
|
|
groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
|
|
|
|
partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
|
|
partMap = Map.fromListWith mappend
|
|
|
|
invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
|
|
invertMap = groupMap . map swap . Map.toList
|
|
|
|
|
|
|
|
-----------
|
|
-- Maybe --
|
|
-----------
|
|
|
|
toMaybe :: Bool -> a -> Maybe a
|
|
toMaybe True = Just
|
|
toMaybe False = const Nothing
|
|
|
|
toNothing :: a -> Maybe b
|
|
toNothing = const Nothing
|
|
|
|
toNothingS :: String -> Maybe b
|
|
toNothingS = const Nothing
|
|
|
|
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
|
|
maybeAdd (Just x) (Just y) = Just (x + y)
|
|
maybeAdd Nothing y = y
|
|
maybeAdd x Nothing = x
|
|
|
|
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
|
|
maybeEmpty (Just x) f = f x
|
|
maybeEmpty Nothing _ = mempty
|
|
|
|
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
|
whenIsJust (Just x) f = f x
|
|
whenIsJust Nothing _ = return ()
|
|
|
|
ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
|
|
ifMaybeM Nothing dft _ = return dft
|
|
ifMaybeM (Just x) _ act = act x
|
|
|
|
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
|
|
maybePositive a | a > 0 = Just a
|
|
| otherwise = Nothing
|
|
|
|
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
|
|
positiveSum (Sum x) = maybePositive x
|
|
|
|
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
|
|
maybeM dft act mb = mb >>= maybe dft act
|
|
|
|
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
|
maybeT x m = runMaybeT m >>= maybe x return
|
|
|
|
maybeT_ :: Monad m => MaybeT m () -> m ()
|
|
maybeT_ = void . runMaybeT
|
|
|
|
catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
|
|
catchIfMaybeT p act = catchIf p (lift act) (const mzero)
|
|
|
|
mcons :: Maybe a -> [a] -> [a]
|
|
mcons Nothing xs = xs
|
|
mcons (Just x) xs = x:xs
|
|
|
|
newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
|
|
|
|
instance Eq a => Eq (NTop (Maybe a)) where
|
|
(NTop x) == (NTop y) = x == y
|
|
|
|
instance Ord a => Ord (NTop (Maybe a)) where
|
|
compare (NTop Nothing) (NTop Nothing) = EQ
|
|
compare (NTop Nothing) _ = GT
|
|
compare _ (NTop Nothing) = LT
|
|
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
|
|
|
|
|
|
|
------------
|
|
-- Either --
|
|
------------
|
|
|
|
maybeLeft :: Either a b -> Maybe a
|
|
maybeLeft (Left a) = Just a
|
|
maybeLeft _ = Nothing
|
|
|
|
maybeRight :: Either a b -> Maybe b
|
|
maybeRight (Right b) = Just b
|
|
maybeRight _ = Nothing
|
|
|
|
whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
|
|
whenIsLeft (Left x) f = f x
|
|
whenIsLeft (Right _) _ = return ()
|
|
|
|
whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
|
|
whenIsRight (Right x) f = f x
|
|
whenIsRight (Left _) _ = return ()
|
|
|
|
|
|
---------------
|
|
-- Exception --
|
|
---------------
|
|
|
|
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
|
|
maybeExceptT err act = lift act >>= maybe (throwE err) return
|
|
|
|
maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
|
|
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
|
|
|
|
whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
|
|
whenExceptT b err = when b $ throwE err
|
|
|
|
whenMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
|
|
whenMExceptT b err = when b $ lift err >>= throwE
|
|
|
|
guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
|
|
guardExceptT b err = unless b $ throwE err
|
|
|
|
guardMExceptT :: Monad m => Bool -> m e -> ExceptT e m ()
|
|
guardMExceptT b err = unless b $ lift err >>= throwE
|
|
|
|
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
|
|
exceptT f g = either f g <=< runExceptT
|
|
|
|
catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
|
|
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
|
|
|
|
|
|
|
|
------------
|
|
-- Monads --
|
|
------------
|
|
|
|
shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
|
|
shortCircuitM sc binOp mx my = do
|
|
x <- mx
|
|
if
|
|
| sc x -> return x
|
|
| otherwise -> binOp <$> pure x <*> my
|
|
|
|
|
|
guardM :: MonadPlus m => m Bool -> m ()
|
|
guardM f = guard =<< f
|
|
|
|
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
|
|
assertM f x = x >>= assertM' f
|
|
|
|
assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
|
|
assertM' f x = x <$ guard (f x)
|
|
|
|
-- Some Utility Functions from Agda.Utils.Monad
|
|
-- | Monadic if-then-else.
|
|
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
|
ifM c m m' =
|
|
do b <- c
|
|
if b then m else m'
|
|
|
|
-- | @ifNotM mc = ifM (not <$> mc)@
|
|
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
|
|
ifNotM c = flip $ ifM c
|
|
|
|
and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
|
|
and2M ma mb = ifM ma mb (return False)
|
|
or2M ma = ifM ma (return True)
|
|
|
|
andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
|
|
andM = Fold.foldr and2M (return True)
|
|
orM = Fold.foldr or2M (return False)
|
|
|
|
allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
|
|
allM xs f = andM $ fmap f xs
|
|
anyM xs f = orM $ fmap f xs
|
|
|
|
ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
|
|
ofoldr1M f (otoList -> x:xs) = foldrM f x xs
|
|
ofoldr1M _ _ = error "otoList of NonNull is empty"
|
|
ofoldl1M f (otoList -> x:xs) = foldlM f x xs
|
|
ofoldl1M _ _ = error "otoList of NonNull is empty"
|
|
|
|
partitionM :: forall mono m .
|
|
( MonoFoldable mono
|
|
, Monoid mono
|
|
, MonoPointed mono
|
|
, Monad m)
|
|
=> (Element mono -> m Bool) -> mono -> m (mono, mono)
|
|
partitionM crit = ofoldlM dist mempty
|
|
where
|
|
dist :: (mono,mono) -> Element mono -> m (mono,mono)
|
|
dist acc x = do
|
|
okay <- crit x
|
|
return $ if
|
|
| okay -> acc `mappend` (opoint x, mempty)
|
|
| otherwise -> acc `mappend` (mempty, opoint x)
|
|
|
|
|
|
--------------
|
|
-- Sessions --
|
|
--------------
|
|
|
|
setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
|
|
setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
|
|
|
|
lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
|
|
lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
|
|
|
|
modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
|
|
modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
|
|
|
|
tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
|
|
tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
|
|
|
|
getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
|
|
-- ^ `lookupSessionJson` followed by `deleteSession`
|
|
getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
|