{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeOperators, GADTs, StandaloneDeriving, IncoherentInstances, AllowAmbiguousTypes, FunctionalDependencies #-}

{-|
Module: IHP.HaskellSupport
Description: Provides helpers to write better haskell code
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.HaskellSupport
( (|>)
, (|>>)
, whenEmpty
, whenNonEmpty
, get
, set
, setJust
, setMaybe
, ifOrEmpty
, modify
, modifyJust
, SetField (..)
, UpdateField (..)
, incrementField
, decrementField
, isToday
, isToday'
, forEach
, forEachWithIndex
, textToInt
, isWeekend
, todayIsWeekend
, debug
, includes
, stripTags
, symbolToText
, symbolToByteString
, IsEmpty (..)
, copyFields
, allEnumValues
) where

import Control.Monad (when, unless, forM_)
import Data.Functor ((<&>))
import Data.String (IsString(..))
import Data.MonoTraversable (MonoFoldable, Element, oelem, oforM_)
import Data.Time.Clock (UTCTime(..), getCurrentTime)
import Data.Time.Calendar (Day, toGregorian)
import Data.Map (Map)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Prelude
import qualified Data.Default
import qualified Data.UUID as UUID
import Data.Proxy
import qualified Data.Time
import GHC.TypeLits
import GHC.OverloadedLabels
import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
import Data.String.Conversions (cs, ConvertibleStrings (..))
import qualified Debug.Trace
import qualified Data.Text as Text
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.Aeson.Key as Aeson

import IHP.Record ((|>), get, set, setJust, setMaybe, modify, modifyJust, SetField(..), UpdateField(..), incrementField, decrementField, CopyFields(..))

infixl 8 |>>
f a
a |>> :: f a -> (a -> b) -> f b
|>> a -> b
b = f a
a f a -> (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> a -> b
b
{-# INLINABLE (|>>) #-}

-- | Used by 'nonEmpty' and 'isEmptyValue' to check for emptyness
class IsEmpty value where
    -- | Returns True when the value is an empty string, empty list, zero UUID, etc.
    isEmpty :: value -> Bool

instance IsEmpty Text where
    isEmpty :: Text -> Bool
isEmpty Text
"" = Bool
True
    isEmpty Text
_ = Bool
False
    {-# INLINE isEmpty #-}

instance IsEmpty (Maybe value) where
    isEmpty :: Maybe value -> Bool
isEmpty Maybe value
Nothing = Bool
True
    isEmpty (Just value
_) = Bool
False
    {-# INLINE isEmpty #-}

instance IsEmpty [a] where
    isEmpty :: [a] -> Bool
isEmpty [] = Bool
True
    isEmpty [a]
_ = Bool
False
    {-# INLINE isEmpty #-}

instance IsEmpty UUID.UUID where
    isEmpty :: UUID -> Bool
isEmpty UUID
uuid = UUID
UUID.nil UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
== UUID
uuid
    {-# INLINE isEmpty #-}

instance IsEmpty (Map a b) where
    isEmpty :: Map a b -> Bool
isEmpty = Map a b -> Bool
forall a b. Map a b -> Bool
Map.null    
    {-# INLINE isEmpty #-}

ifOrEmpty :: (Monoid a) => Bool -> a -> a
ifOrEmpty :: forall a. Monoid a => Bool -> a -> a
ifOrEmpty Bool
bool a
a = if Bool
bool then a
a else a
forall a. Monoid a => a
mempty
{-# INLINE ifOrEmpty #-}

whenEmpty :: value -> f () -> f ()
whenEmpty value
condition = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (value -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty value
condition)
{-# INLINE whenEmpty #-}

whenNonEmpty :: (IsEmpty a, Applicative f) => a -> f () -> f ()
whenNonEmpty :: forall a (f :: * -> *).
(IsEmpty a, Applicative f) =>
a -> f () -> f ()
whenNonEmpty a
condition = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty a
condition)
{-# INLINE whenNonEmpty #-}

-- Returns 'True' when a value is contained in the given list, array, set, ...
--
-- Alias for 'elem', but with a nicer name :)
--
-- >>> ["hello", "world"] |> includes "hello"
-- True
--
-- >>> "Hello" |> includes 'H'
-- True
includes :: (MonoFoldable container, Eq (Element container)) => Element container -> container -> Bool
includes :: forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes = Element container -> container -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
oelem
{-# INLINE includes #-}

instance Data.Default.Default UUID.UUID where
    def :: UUID
def = UUID
UUID.nil
    {-# INLINE def #-}

instance forall name name'. (KnownSymbol name, name' ~ name) => IsLabel name (Proxy name') where
    fromLabel :: Proxy name'
fromLabel = forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name'
    {-# INLINE fromLabel #-}

utcTimeToYearMonthDay :: UTCTime -> (Integer, Int, Int)
utcTimeToYearMonthDay :: UTCTime -> (Integer, Int, Int)
utcTimeToYearMonthDay = Day -> (Integer, Int, Int)
toGregorian (Day -> (Integer, Int, Int))
-> (UTCTime -> Day) -> UTCTime -> (Integer, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Day
utctDay -- (year,month,day)

isToday :: UTCTime -> IO Bool
isToday :: UTCTime -> IO Bool
isToday UTCTime
timestamp = do
    now <- IO UTCTime
getCurrentTime
    pure (isToday' now timestamp)

isToday' :: UTCTime -> UTCTime -> Bool
isToday' :: UTCTime -> UTCTime -> Bool
isToday' UTCTime
currentTime UTCTime
timestamp = UTCTime -> (Integer, Int, Int)
utcTimeToYearMonthDay UTCTime
currentTime (Integer, Int, Int) -> (Integer, Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime -> (Integer, Int, Int)
utcTimeToYearMonthDay UTCTime
timestamp

-- | Allows `Just "someThing"` to be written as `"someThing"`
instance IsString string => IsString (Maybe string) where
    fromString :: String -> Maybe string
fromString String
string = string -> Maybe string
forall a. a -> Maybe a
Just (String -> string
forall a. IsString a => String -> a
fromString String
string)
    {-# INLINE fromString #-}


-- | Example:
--
-- > forEach users \user -> putStrLn (tshow user)
--
-- __Example:__ Within HSX
--
-- > renderUser :: User -> Html
-- > renderUser user = [hsx|<div>User: {user.name}</div>|]
-- >
-- > render = [hsx|{forEach users renderUser}|]
--
forEach :: (MonoFoldable mono, Applicative m) => mono -> (Element mono -> m ()) -> m ()
forEach :: forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forEach mono
elements Element mono -> m ()
function = mono -> (Element mono -> m ()) -> m ()
forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forall (m :: * -> *).
Applicative m =>
mono -> (Element mono -> m ()) -> m ()
oforM_ mono
elements Element mono -> m ()
function
{-# INLINE forEach #-}


-- | Like 'forEach' but with an index, starting at 0
--
-- __Example:__ With a Callback
--
-- > forEachWithIndex users \(index, user) -> putStrLn (tshow index <> ": " <> tshow user)
--
-- __Example:__ With a Function
--
-- > printUser :: (Int, User) -> IO ()
-- > printUser (index, user) = putStrLn (tshow index <> ": " <> tshow user)
-- >
-- > forEachWithIndex users printUser
--
-- __Example:__ Within HSX
--
-- > renderUser :: (Int, User) -> Html
-- > renderUser (index, user) = [hsx|<div>User {index}: {user.name}</div>|]
-- >
-- > render = [hsx|{forEachWithIndex users renderUser}|]
--
forEachWithIndex :: (Monad m) => [a] -> ((Int, a) -> m ()) -> m ()
forEachWithIndex :: forall (m :: * -> *) a.
Monad m =>
[a] -> ((Int, a) -> m ()) -> m ()
forEachWithIndex [a]
elements (Int, a) -> m ()
function = [(Int, a)] -> ((Int, a) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [a]
elements) (Int, a) -> m ()
function
{-# INLINE forEachWithIndex #-}

-- | Parses a text to an int. Returns @Nothing@ on failure.
--
-- __Example:__
--
-- >>> textToInt "1337"
-- Just 1337
--
-- >>> textToInt "bad input"
-- Nothing
textToInt :: Text -> Maybe Int
textToInt :: Text -> Maybe Int
textToInt Text
text = case Parser Int -> ByteString -> Either String Int
forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly (Parser Int
forall a. Integral a => Parser a
Attoparsec.decimal Parser Int -> Parser ByteString () -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
text) of
    Right Int
value -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
value
    Left String
_error -> Maybe Int
forall a. Maybe a
Nothing

-- | Returns @True@ when today is Saturday or Sunday.
--
-- __Example:__
--
-- > do
-- >     todayIsWeekend <- isWeekend
-- >     when todayIsWeekend (putStrLn "It's weekend!")
todayIsWeekend :: IO Bool
todayIsWeekend :: IO Bool
todayIsWeekend = do
    now <- IO UTCTime
Data.Time.getCurrentTime
    let today = UTCTime -> Day
Data.Time.utctDay UTCTime
now
    return (isWeekend today)

-- | Returns @True@ when day is Saturday or Sunday.
--
-- __Example:__
--
-- >>> isWeekend $ fromGregorian 2019 10 7
-- False
--
-- >>> isWeekend $ fromGregorian 2020 6 13
-- True
isWeekend :: Day -> Bool
isWeekend :: Day -> Bool
isWeekend Day
day =
  DayOfWeek
weekday DayOfWeek -> DayOfWeek -> Bool
forall a. Eq a => a -> a -> Bool
== DayOfWeek
Data.Time.Saturday Bool -> Bool -> Bool
|| DayOfWeek
weekday DayOfWeek -> DayOfWeek -> Bool
forall a. Eq a => a -> a -> Bool
== DayOfWeek
Data.Time.Sunday
  where
    weekday :: DayOfWeek
weekday = Day -> DayOfWeek
Data.Time.dayOfWeek Day
day

-- | Debug-print a value during evaluation
--
-- Alias for 'Debug.Trace.traceShowId'
debug :: Show value => value -> value
debug :: forall value. Show value => value -> value
debug value
value = value -> value
forall value. Show value => value -> value
Debug.Trace.traceShowId value
value
{-# INLINE debug #-}

-- | Removes all html tags from a given html text
--
-- >>> stripTags "This is <b>Bold</b>"
-- "This is Bold"
stripTags :: Text -> Text
stripTags :: Text -> Text
stripTags Text
"" = Text
""
stripTags Text
html | HasCallStack => Text -> Char
Text -> Char
Text.head Text
html Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' = Text -> Text
stripTags (Int -> Text -> Text
Text.drop Int
1 ((Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') (HasCallStack => Text -> Text
Text -> Text
Text.tail Text
html)))
stripTags Text
html = let (Text
a, Text
b) = Int -> Text -> (Text, Text)
Text.splitAt Int
1 Text
html in Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
stripTags Text
b

-- | Returns the value of a type level symbol as a text
--
-- >>> symbolToText @"hello"
-- "hello"
--
-- >>> symbolToText @(GetTableName User)
-- "users"
symbolToText :: forall symbol. (KnownSymbol symbol) => Text
symbolToText :: forall (symbol :: Symbol). KnownSymbol symbol => Text
symbolToText = String -> Text
Text.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @symbol Proxy symbol
forall {k} (t :: k). Proxy t
Proxy)
{-# INLINE symbolToText #-}

-- | Returns the value of a type level symbol as a bytestring
--
-- >>> symbolToByteString @"hello"
-- "hello"
--
-- >>> symbolToByteString @(GetTableName User)
-- "users"
symbolToByteString :: forall symbol. (KnownSymbol symbol) => ByteString
symbolToByteString :: forall (symbol :: Symbol). KnownSymbol symbol => ByteString
symbolToByteString = String -> ByteString
ByteString.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @symbol Proxy symbol
forall {k} (t :: k). Proxy t
Proxy)
{-# INLINE symbolToByteString #-}

instance IsString UUID.UUID where
    fromString :: String -> UUID
fromString String
string = case String -> Maybe UUID
UUID.fromString String
string of
            Just UUID
uuid -> UUID
uuid
            Maybe UUID
Nothing -> String -> UUID
forall a. HasCallStack => String -> a
error (String
"Invalid UUID: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
string)

-- | Returns a list of all values of an enum type
--
-- Given a data structure like this:
--
-- > data Color = Yellow | Red | Blue deriving (Enum)
--
-- You can call 'allEnumValues' to get a list of all colors:
--
-- >>> allEnumValues @Color
-- [Yellow, Red, Blue]
--
-- This also works if the enum is defined in the @Schema.sql@:
--
-- > CREATE TYPE brokerage_subscription_type AS ENUM ('basic_subscription', 'bronze_subscription', 'silver_subscription', 'gold_subscription');
--
-- >>> allEnumValues @BrokerageSubscriptionType
-- [BasicSubscription, BronzeSubscription, SilverSubscription]
--
allEnumValues :: forall enumType. Enum enumType => [enumType]
allEnumValues :: forall enumType. Enum enumType => [enumType]
allEnumValues = enumType -> [enumType]
forall a. Enum a => a -> [a]
enumFrom (Int -> enumType
forall a. Enum a => Int -> a
toEnum Int
0)
{-# INLINABLE allEnumValues #-}

instance ConvertibleStrings ByteString Aeson.Key where
    convertString :: ByteString -> Key
convertString ByteString
byteString = Text -> Key
Aeson.fromText (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString)
instance ConvertibleStrings Text Aeson.Key where
    convertString :: Text -> Key
convertString Text
text = Text -> Key
Aeson.fromText Text
text