content: {-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, 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.Map as Map
  import qualified Data.ByteString.Char8 as ByteString
  import qualified Data.Aeson.Key as Aeson
  
  --(|>) :: a -> f -> f a
  infixl 8 |>
  a |> f = f a
  {-# INLINE (|>) #-}
  
  infixl 8 |>>
  a |>> b = a <&> 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 "" = True
      isEmpty _ = False
      {-# INLINE isEmpty #-}
  
  instance IsEmpty (Maybe value) where
      isEmpty Nothing = True
      isEmpty (Just _) = False
      {-# INLINE isEmpty #-}
  
  instance IsEmpty [a] where
      isEmpty [] = True
      isEmpty _ = False
      {-# INLINE isEmpty #-}
  
  instance IsEmpty UUID.UUID where
      isEmpty uuid = UUID.nil == uuid
      {-# INLINE isEmpty #-}
  
  instance IsEmpty (Map a b) where
      isEmpty = Map.null    
      {-# INLINE isEmpty #-}
  
  ifOrEmpty :: (Monoid a) => Bool -> a -> a
  ifOrEmpty bool a = if bool then a else mempty
  {-# INLINE ifOrEmpty #-}
  
  whenEmpty condition = when (isEmpty condition)
  {-# INLINE whenEmpty #-}
  
  whenNonEmpty :: (IsEmpty a, Applicative f) => a -> f () -> f ()
  whenNonEmpty condition = unless (isEmpty 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 = elem
  {-# INLINE includes #-}
  
  instance Data.Default.Default UUID.UUID where
      def = UUID.nil
      {-# INLINE def #-}
  
  instance forall name name'. (KnownSymbol name, name' ~ name) => IsLabel name (Proxy name') where
      fromLabel = 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 }
  --
  -- >>> project.name
  -- "Hello World"
  --
  -- >>> project.isPublic
  -- False
  get :: forall model name value. (KnownSymbol name, Record.HasField name model value) => Proxy name -> model -> value
  get _ record = Record.getField @name 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 name value record = setField @name value 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 name value record = case value of
      Just value -> setField @name (Just value) record
      Nothing    -> 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 name value record = setField @name (Just value) 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 _ updateFunction model = let value = Record.getField @name model in setField @name (updateFunction value) 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. (KnownSymbol name, Record.HasField name model (Maybe value), SetField name model (Maybe value)) => Proxy name -> (value -> value) -> model -> model
  modifyJust _ updateFunction model = case Record.getField @name model of
          Just value -> setField @name (Just (updateFunction value)) model
          Nothing -> 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 _ model = let value = Record.getField @name model in setField @name (value + 1) 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 _ model = let value = Record.getField @name model in setField @name (value - 1) 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 = toGregorian . utctDay -- (year,month,day)
  
  isToday :: UTCTime -> IO Bool
  isToday timestamp = do
      now <- getCurrentTime
      pure (isToday' now timestamp)
  
  isToday' :: UTCTime -> UTCTime -> Bool
  isToday' currentTime timestamp = utcTimeToYearMonthDay currentTime == utcTimeToYearMonthDay timestamp
  
  -- | Allows `Just "someThing"` to be written as `"someThing"`
  instance IsString string => IsString (Maybe string) where
      fromString string = Just (fromString 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 elements function = forM_ elements 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 :: (Applicative m) => [a] -> ((Int, a) -> m ()) -> m ()
  forEachWithIndex elements function = forM_ (ClassyPrelude.zip [0..] elements) 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 = case Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) (cs text) of
      Right value -> Just value
      Left _error -> Nothing
  
  -- | Returns @True@ when today is Saturday or Sunday.
  --
  -- __Example:__
  --
  -- > do
  -- >     todayIsWeekend <- isWeekend
  -- >     when todayIsWeekend (putStrLn "It's weekend!")
  todayIsWeekend :: IO Bool
  todayIsWeekend = do
      now <- Data.Time.getCurrentTime
      let today = Data.Time.utctDay 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 =
    weekday == Data.Time.Saturday || weekday == Data.Time.Sunday
    where
      weekday = Data.Time.dayOfWeek day
  
  -- | Debug-print a value during evaluation
  --
  -- Alias for 'Debug.Trace.traceShowId'
  debug :: Show value => value -> value
  debug value = Debug.Trace.traceShowId 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 "" = ""
  stripTags html | Text.head html == '<' = stripTags (Text.drop 1 (Text.dropWhile (/= '>') (Text.tail html)))
  stripTags html = let (a, b) = Text.splitAt 1 html in a <> stripTags 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.pack (symbolVal @symbol 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.pack (symbolVal @symbol Proxy)
  {-# INLINE symbolToByteString #-}
  
  instance IsString UUID.UUID where
      fromString string = case UUID.fromString string of
              Just uuid -> uuid
              Nothing -> error ("Invalid UUID: " <> 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 (otherProject.name)
      -- >     |> set #isPublic (otherProject.isPublic)
      -- >     |> set #userId (otherProject.userId)
      --
      -- 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
      {-# 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
              |> set (Proxy @fieldName) (Record.getField @fieldName sourceRecord)
              |> copyFields @rest 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 = enumFrom (toEnum 0)
  {-# INLINABLE allEnumValues #-}
  
  instance ConvertibleStrings ByteString Aeson.Key where
      convertString byteString = Aeson.fromText (cs byteString)
  instance ConvertibleStrings Text Aeson.Key where
      convertString text = Aeson.fromText text
  