fradrive/src/Utils.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult

module Utils
  ( module Utils
  ) where

import ClassyPrelude.Yesod

-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.Foldable as Fold

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Utils.DB as Utils
import Utils.Common as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils

import Text.Blaze (Markup, ToMarkup)

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)

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

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)


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

instance DisplayAble a => DisplayAble (CI a) where
  display = display . CI.original

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

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


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

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

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 ()

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

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

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