{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, 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 ClassyPrelude
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 GHC.Records as Record
import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
import Data.String.Conversions (cs)
import qualified Debug.Trace
import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as ByteString

--(|>) :: a -> f -> f a
infixl 8 |>
t
a |> :: t -> (t -> t) -> t
|> t -> t
f = t -> t
f t
a
{-# INLINE (|>) #-}

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

ifOrEmpty :: (Monoid a) => Bool -> a -> a
ifOrEmpty :: 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 :: 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 :: Element container -> container -> Bool
includes = Element container -> container -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
elem
{-# 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 = Proxy name'
forall k (t :: k). Proxy t
Proxy @name'
    {-# INLINE fromLabel #-}

-- | Returns the field value for a field name
--
-- __Example:__
--
-- > data Project = Project { name :: Text, isPublic :: Bool }
-- >
-- > let project = Project { name = "Hello World", isPublic = False }
--
-- >>> get #name project
-- "Hello World"
--
-- >>> get #isPublic project
-- False
get :: forall model name value. (KnownSymbol name, Record.HasField name model value) => Proxy name -> model -> value
get :: Proxy name -> model -> value
get Proxy name
_ model
record = model -> value
forall k (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
record
{-# INLINE get #-}

-- | Sets a field of a record and returns the new record.
--
-- __Example:__
--
-- > data Project = Project { name :: Text, isPublic :: Bool }
-- >
-- > let project = Project { name = "Hello World", isPublic = False }
--
-- >>> set #name "New Name" project
-- Project { name = "New Name", isPublic = False }
--
-- >>> set #isPublic True project
-- Project { name = "Hello World", isPublic = True }
set :: forall model name value. (KnownSymbol name, SetField name model value) => Proxy name -> value -> model -> model
set :: Proxy name -> value -> model -> model
set Proxy name
name value
value model
record = value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name value
value model
record
{-# INLINE set #-}


-- | Like 'set' but doesn't set the value if it's 'Nothing'. Useful when you update NULL values
-- | e.g. via a cron job and don't want to lose that work on subsequent updates.
--
-- __Example:__
--
-- > data Project = Project { name :: Maybe Text }
-- >
-- > let project = Project { name = Nothing }
--
-- >>> setMaybe #name (Just "New Name") project
-- Project { name = Just "New Name" }
--
-- >>> setMaybe #name Nothing project
-- Project { name = Just "New Name" } -- previous value is kept
--
setMaybe :: forall model name value. (KnownSymbol name, SetField name model (Maybe value)) => Proxy name -> Maybe value -> model -> model
setMaybe :: Proxy name -> Maybe value -> model -> model
setMaybe Proxy name
name Maybe value
value model
record = case Maybe value
value of
    Just value
value -> Maybe value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (value -> Maybe value
forall a. a -> Maybe a
Just value
value) model
record
    Maybe value
Nothing    -> model
record
{-# INLINE setMaybe #-}


-- | Like 'set' but wraps the value with a 'Just'. Useful when you want to set a 'Maybe' field
--
-- __Example:__
--
-- > data Project = Project { name :: Maybe Text }
-- >
-- > let project = Project { name = Nothing }
--
-- >>> setJust #name "New Name" project
-- Project { name = Just "New Name" }
--
setJust :: forall model name value. (KnownSymbol name, SetField name model (Maybe value)) => Proxy name -> value -> model -> model
setJust :: Proxy name -> value -> model -> model
setJust Proxy name
name value
value model
record = Maybe value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (value -> Maybe value
forall a. a -> Maybe a
Just value
value) model
record
{-# INLINE setJust #-}


modify :: forall model name value. (KnownSymbol name, Record.HasField name model value, SetField name model value) => Proxy name -> (value -> value) -> model -> model
modify :: Proxy name -> (value -> value) -> model -> model
modify Proxy name
_ value -> value
updateFunction model
model = let value :: value
value = model -> value
forall k (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model in value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (value -> value
updateFunction value
value) model
model
{-# INLINE modify #-}

-- Like 'modify', but only modifies the value if it's not Nothing.
--
-- __Example:__
--
-- > let pauseDuration = now `diffUTCTime` pausedAt
-- >
-- > floorTimer <- floorTimer
-- >         |> modifyJust #startedAt (addUTCTime pauseDuration)
-- >         |> updateRecord
--
modifyJust :: forall model name value updateFunction. (KnownSymbol name, Record.HasField name model (Maybe value), SetField name model (Maybe value)) => Proxy name -> (value -> value) -> model -> model
modifyJust :: Proxy name -> (value -> value) -> model -> model
modifyJust Proxy name
_ value -> value
updateFunction model
model = case model -> Maybe value
forall k (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model of
        Just value
value -> Maybe value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (value -> Maybe value
forall a. a -> Maybe a
Just (value -> value
updateFunction value
value)) model
model
        Maybe value
Nothing -> model
model
{-# INLINE modifyJust #-}

-- | Plus @1@ on record field.
--
-- __Example:__
--
-- > data Project = Project { name :: Text, followersCount :: Int }
-- >
-- > let project = Project { name = "Hello World", followersCount = 0 }
--
-- >>> project |> incrementField #followersCount
-- Project { name = "Hello World", followersCount = 1 }
incrementField :: forall model name value. (KnownSymbol name, Record.HasField name model value, SetField name model value, Num value) => Proxy name -> model -> model
incrementField :: Proxy name -> model -> model
incrementField Proxy name
_ model
model = let value :: value
value = model -> value
forall k (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model in value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (value
value value -> value -> value
forall a. Num a => a -> a -> a
+ value
1) model
model
{-# INLINE incrementField #-}

-- | Minus @1@ on a record field.
--
-- __Example:__
--
-- > data Project = Project { name :: Text, followersCount :: Int }
-- >
-- > let project = Project { name = "Hello World", followersCount = 1337 }
--
-- >>> project |> decrementField #followersCount
-- Project { name = "Hello World", followersCount = 1336 }
decrementField :: forall model name value. (KnownSymbol name, Record.HasField name model value, SetField name model value, Num value) => Proxy name -> model -> model
decrementField :: Proxy name -> model -> model
decrementField Proxy name
_ model
model = let value :: value
value = model -> value
forall k (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model in value -> model -> model
forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (value
value value -> value -> value
forall a. Num a => a -> a -> a
- value
1) model
model
{-# INLINE decrementField #-}

class SetField (field :: GHC.TypeLits.Symbol) model value | field model -> value where
    setField :: value -> model -> model

class Record.HasField field model value => UpdateField (field :: GHC.TypeLits.Symbol) model model' value value' | model model' value' -> value where
    updateField :: value' -> model -> model'

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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> Day
utctDay -- (year,month,day)

isToday :: UTCTime -> IO Bool
isToday :: UTCTime -> IO Bool
isToday UTCTime
timestamp = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> UTCTime -> Bool
isToday' UTCTime
now UTCTime
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: {get #name user}</div>|]
-- >
-- > render = [hsx|{forEach users renderUser}|]
--
forEach :: (MonoFoldable mono, Applicative m) => mono -> (Element mono -> m ()) -> m ()
forEach :: 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 ()
forM_ 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}: {get #name user}</div>|]
-- >
-- > render = [hsx|{forEachWithIndex users renderUser}|]
--
forEachWithIndex :: (Applicative m) => [a] -> ((Int, a) -> m ()) -> m ()
forEachWithIndex :: [a] -> ((Int, a) -> m ()) -> m ()
forEachWithIndex [a]
elements (Int, a) -> m ()
function = [(Int, a)] -> (Element [(Int, a)] -> m ()) -> m ()
forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forM_ ([Int] -> [a] -> [(Int, a)]
forall (f :: * -> *) a b. Zip f => f a -> f b -> f (a, b)
ClassyPrelude.zip [Int
0..] [a]
elements) (Int, a) -> m ()
Element [(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 (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
    UTCTime
now <- IO UTCTime
Data.Time.getCurrentTime
    let today :: Day
today = UTCTime -> Day
Data.Time.utctDay UTCTime
now
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> Bool
isWeekend Day
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 :: value -> value
debug value
value = value -> value
forall a. Show a => a -> a
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 | 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
'>') (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 :: Text
symbolToText = String -> Text
Text.pack (Proxy symbol -> String
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 :: ByteString
symbolToByteString = String -> ByteString
ByteString.pack (Proxy symbol -> String
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)


class CopyFields (fields :: [Symbol]) destinationRecord sourceRecord where
    -- | Provides the 'copyFields' function
    --
    -- Useful to rewrite getter-setter code like this:
    --
    -- > let newProject = newRecord @Project
    -- >     |> set #name (get #name otherProject)
    -- >     |> set #isPublic (get #isPublic otherProject)
    -- >     |> set #userId (get #userId otherProject)
    --
    -- With 'copyFields' this can be written like this:
    --
    -- > let newProject = newRecord @Project
    -- >     |> copyFields @["name", "isPublic", "userId"] otherProject
    --
    copyFields :: sourceRecord -> destinationRecord -> destinationRecord

instance CopyFields ('[]) destinationRecord sourceRecord where
    copyFields :: sourceRecord -> destinationRecord -> destinationRecord
copyFields sourceRecord
sourceRecord destinationRecord
destinationRecord = destinationRecord
destinationRecord
    {-# INLINE copyFields #-}

instance (CopyFields rest destinationRecord sourceRecord
    , KnownSymbol fieldName
    , SetField fieldName destinationRecord fieldType
    , Record.HasField fieldName sourceRecord fieldType
    ) => CopyFields (fieldName:rest) destinationRecord sourceRecord where
    copyFields :: sourceRecord -> destinationRecord -> destinationRecord
copyFields sourceRecord
sourceRecord destinationRecord
destinationRecord =
            destinationRecord
destinationRecord
            destinationRecord
-> (destinationRecord -> destinationRecord) -> destinationRecord
forall t t. t -> (t -> t) -> t
|> Proxy fieldName
-> fieldType -> destinationRecord -> destinationRecord
forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set (Proxy fieldName
forall k (t :: k). Proxy t
Proxy @fieldName) (sourceRecord -> fieldType
forall k (x :: k) r a. HasField x r a => r -> a
Record.getField @fieldName sourceRecord
sourceRecord)
            destinationRecord
-> (destinationRecord -> destinationRecord) -> destinationRecord
forall t t. t -> (t -> t) -> t
|> sourceRecord -> destinationRecord -> destinationRecord
forall (fields :: [Symbol]) destinationRecord sourceRecord.
CopyFields fields destinationRecord sourceRecord =>
sourceRecord -> destinationRecord -> destinationRecord
copyFields @rest sourceRecord
sourceRecord
    {-# INLINE copyFields #-}

-- | 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 :: [enumType]
allEnumValues = enumType -> [enumType]
forall a. Enum a => a -> [a]
enumFrom (Int -> enumType
forall a. Enum a => Int -> a
toEnum Int
0)
{-# INLINABLE allEnumValues #-}