{-# 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, ConvertibleStrings (..))
import qualified Debug.Trace
import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.Aeson.Key as Aeson

--(|>) :: 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 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 forall a. Eq a => a -> a -> Bool
== UUID
uuid
    {-# 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 forall a. Monoid a => a
mempty
{-# INLINE ifOrEmpty #-}

whenEmpty :: value -> f () -> f ()
whenEmpty value
condition = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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 = forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> 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 = 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 :: forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
_ model
record = 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 :: forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set Proxy name
name value
value model
record = 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 :: forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model (Maybe value)) =>
Proxy name -> Maybe value -> model -> model
setMaybe Proxy name
name Maybe value
value model
record = case Maybe value
value of
    Just value
value -> forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (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 :: forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model (Maybe value)) =>
Proxy name -> value -> model -> model
setJust Proxy name
name value
value model
record = forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (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 :: forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value,
 SetField name model value) =>
Proxy name -> (value -> value) -> model -> model
modify Proxy name
_ value -> value
updateFunction model
model = let value :: value
value = forall {k} (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model in 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 :: forall {k} model (name :: Symbol) value (updateFunction :: k).
(KnownSymbol name, HasField name model (Maybe value),
 SetField name model (Maybe value)) =>
Proxy name -> (value -> value) -> model -> model
modifyJust Proxy name
_ value -> value
updateFunction model
model = case forall {k} (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model of
        Just value
value -> forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (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 :: forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value,
 SetField name model value, Num value) =>
Proxy name -> model -> model
incrementField Proxy name
_ model
model = let value :: value
value = forall {k} (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model in forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (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 :: forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value,
 SetField name model value, Num value) =>
Proxy name -> model -> model
decrementField Proxy name
_ model
model = let value :: value
value = forall {k} (x :: k) r a. HasField x r a => r -> a
Record.getField @name model
model in forall (field :: Symbol) model value.
SetField field model value =>
value -> model -> model
setField @name (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 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
    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 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 = forall a. a -> Maybe a
Just (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 :: forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forEach mono
elements Element mono -> m ()
function = 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 :: forall (m :: * -> *) a.
Applicative m =>
[a] -> ((Int, a) -> m ()) -> m ()
forEachWithIndex [a]
elements (Int, a) -> m ()
function = forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forM_ (forall (f :: * -> *) a b. Zip f => f a -> f b -> f (a, b)
ClassyPrelude.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 forall a. Parser a -> ByteString -> Either String a
Attoparsec.parseOnly (forall a. Integral a => Parser a
Attoparsec.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
Attoparsec.endOfInput) (forall a b. ConvertibleStrings a b => a -> b
cs Text
text) of
    Right Int
value -> forall a. a -> Maybe a
Just Int
value
    Left String
_error -> 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
    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 forall a. Eq a => a -> a -> Bool
== DayOfWeek
Data.Time.Saturday Bool -> Bool -> Bool
|| DayOfWeek
weekday 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 = 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 | Text -> Char
Text.head Text
html forall a. Eq a => a -> a -> Bool
== Char
'<' = Text -> Text
stripTags (Int -> Text -> Text
Text.drop Int
1 ((Char -> Bool) -> Text -> Text
Text.dropWhile (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 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 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 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 -> forall a. HasCallStack => String -> a
error (String
"Invalid UUID: " 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
            forall {t} {t}. t -> (t -> t) -> t
|> forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set (forall {k} (t :: k). Proxy t
Proxy @fieldName) (forall {k} (x :: k) r a. HasField x r a => r -> a
Record.getField @fieldName sourceRecord
sourceRecord)
            forall {t} {t}. t -> (t -> t) -> t
|> 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 :: forall enumType. Enum enumType => [enumType]
allEnumValues = forall a. Enum a => a -> [a]
enumFrom (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 (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