255 lines
6.9 KiB
Haskell
255 lines
6.9 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
|
|
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
|
|
|
|
module Utils
|
|
( module Utils
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import Data.List (foldl)
|
|
import Data.Foldable as Fold
|
|
import qualified Data.Char as Char
|
|
|
|
import Utils.DB as Utils
|
|
import Utils.Common as Utils
|
|
import Utils.DateTime as Utils
|
|
|
|
import Text.Blaze (Markup, ToMarkup)
|
|
|
|
-- 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)
|
|
|
|
-----------
|
|
-- 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
|
|
|
|
|
|
|
|
---------------------
|
|
-- Text and String --
|
|
---------------------
|
|
|
|
tickmark :: IsString a => a
|
|
tickmark = fromString "✔"
|
|
|
|
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
|
|
|
|
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
|
|
Text -> WidgetT site m ()
|
|
text2widget t = [whamlet|#{t}|]
|
|
|
|
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
|
|
String -> WidgetT site m ()
|
|
str2widget s = [whamlet|#{s}|]
|
|
|
|
|
|
withFragment :: ( Monad m
|
|
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
|
|
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
|
|
|
|
|
|
uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
|
|
uncamel = ("theme-" ++) . reverse . foldl helper []
|
|
where
|
|
helper _ '.' = []
|
|
helper acc c
|
|
| Char.isSpace c = acc
|
|
| Char.isUpper c = Char.toLower c : '-' : acc
|
|
| otherwise = c : acc
|
|
|
|
camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
|
|
camelSpace = reverse . foldl helper []
|
|
where
|
|
helper _ '.' = []
|
|
helper acc c
|
|
| Char.isSpace c = acc
|
|
| Char.isUpper c = c : ' ' : acc
|
|
| otherwise = c : acc
|
|
|
|
-- Convert anything to Text, and I don't care how
|
|
class DisplayAble a where
|
|
display :: a -> Text
|
|
|
|
instance DisplayAble Text where
|
|
display = id
|
|
|
|
instance DisplayAble String where
|
|
display = pack
|
|
|
|
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
|
|
|
|
-- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
|
|
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
|
|
display = pack . show
|
|
|
|
|
|
|
|
------------
|
|
-- 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
|
|
|
|
|
|
----------
|
|
-- Maps --
|
|
----------
|
|
|
|
|
|
-----------
|
|
-- Maybe --
|
|
-----------
|
|
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
|
whenIsJust (Just x) f = f x
|
|
whenIsJust Nothing _ = return ()
|
|
|
|
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
|
maybeT x m = runMaybeT m >>= maybe x return
|
|
|
|
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
|
|
|
|
---------------
|
|
-- 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) -> m a -> m a -> (a -> a -> a) -> m a
|
|
shortCircuitM sc mx my op = do
|
|
x <- mx
|
|
case sc x of
|
|
True -> return x
|
|
False -> op <$> pure x <*> my
|
|
|
|
|
|
guardM :: MonadPlus m => m Bool -> m ()
|
|
guardM f = guard =<< f
|
|
|
|
-- 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
|
|
|
|
-- | Lazy monadic conjunction.
|
|
and2M :: Monad m => m Bool -> m Bool -> m Bool
|
|
and2M ma mb = ifM ma mb (return False)
|
|
|
|
andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
|
|
andM = Fold.foldr and2M (return True)
|
|
|
|
allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
|
|
allM xs f = andM $ fmap f xs
|
|
|
|
-- | Lazy monadic disjunction.
|
|
or2M :: Monad m => m Bool -> m Bool -> m Bool
|
|
or2M ma mb = ifM ma (return True) mb
|
|
|
|
orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
|
|
orM = Fold.foldr or2M (return False)
|
|
|
|
anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
|
|
anyM xs f = orM $ fmap f xs
|