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

{-|
Module: IHP.Record
Description: Type-level record field operations
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.Record
( (|>)
, get
, set
, setJust
, setMaybe
, modify
, modifyJust
, SetField (..)
, UpdateField (..)
, incrementField
, decrementField
, CopyFields (..)
) where

import Data.Proxy
import GHC.TypeLits
import qualified GHC.Records as Record
import Prelude

-- | Pipe operator
infixl 8 |>
(|>) :: a -> (a -> b) -> b
a
a |> :: forall a b. a -> (a -> b) -> b
|> a -> b
f = a -> b
f a
a
{-# INLINE (|>) #-}

-- | Returns the field value for a field name
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
forall (x :: Symbol) 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.
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'.
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 (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'.
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 (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 :: 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
forall (x :: Symbol) 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.
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 :: forall model (name :: Symbol) value.
(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
forall (x :: Symbol) 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 (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.
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
forall (x :: Symbol) 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 value -> value -> value
forall a. Num a => a -> a -> a
+ value
1) model
model
{-# INLINE incrementField #-}

-- | Minus @1@ on a record field.
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
forall (x :: Symbol) 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 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'

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