{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, IncoherentInstances, AllowAmbiguousTypes, FunctionalDependencies #-}
module IHP.HaskellSupport (
(|>)
, isEmpty
, whenEmpty
, whenNonEmpty
, get
, set
, setJust
, ifOrEmpty
, modify
, SetField (..)
, UpdateField (..)
, incrementField
, decrementField
, isToday
, isToday'
, forEach
, forEachWithIndex
, textToInt
, isWeekend
, todayIsWeekend
, debug
, includes
, stripTags
, symbolToText
, symbolToByteString
, IsEmpty (..)
, copyFields
) where
import ClassyPrelude
import Control.Monad (when)
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.Maybe
import qualified Data.ByteString.Char8 as ByteString
infixl 8 |>
t
a |> :: t -> (t -> t) -> t
|> t -> t
f = t -> t
f t
a
{-# INLINE (|>) #-}
class IsEmpty value where
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
{-# INLINE modify #-}
modify :: forall model name value updateFunction. (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
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 #-}
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
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
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 #-}
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 #-}
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 #-}
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
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)
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 :: 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 #-}
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
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 #-}
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
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 #-}