{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE Safe, GADTs, DefaultSignatures, KindSignatures, DataKinds, CPP #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}

-- For [ghc-8.0 .. ghc-8.4) support.
#if __GLASGOW_HASKELL__ < 840
{-# LANGUAGE TypeInType #-}
#endif

{- |
    License     :  BSD-style
    Module      :  Data.Property
    Copyright   :  (c) Andrey Mulik 2020
    Maintainer  :  work.a.mulik@gmail.com
    
    @Data.Property@ new-style properties.
-}
module Data.Property
(
  -- * Generalized properties
  IsProp (..), PropertyKind, FieldKind, Prop (..),
  
  -- ** Basic properties
  FieldGet (..), get, gets',
  FieldSet (..), set, sets',
  
  -- *** Set properties
  pattern (:=), pattern (::=), pattern (:=$), pattern (::=$),
  
  -- *** Monadic set properties
  pattern (:<=), pattern (:<=$), pattern (:=<), pattern (:=<$),
  
  -- ** Modify properties
  FieldModify (..),
  
  -- *** Modify properties
  pattern (:~), pattern (:~$), pattern (::~), pattern (::~$),
  
  -- *** Monadic modify properties
  pattern (:<~), pattern (:<~$), pattern (:~<), pattern (:~<$),
  
  -- ** Switch properties
  IsSwitch (..), FieldSwitch (..), switch, incr, decr
)
where

import Data.Typeable
import Data.Kind

import Control.Monad

default ()

--------------------------------------------------------------------------------

{- Generalized property. -}

{- |
  @since 0.2
  'Prop' is new, generalized and extensible property type (existential), which
  may contain any 'IsProp' value.
-}
data Prop m field record
  where
    Prop :: (Monad m, IsProp prop) => prop m field record -> Prop m field record
  deriving ( Typeable )

{- |
  @since 0.2
  'IsProp' is a property class that allows you to extend @fmr@ syntax. Now you
  can create new property types and use it with existing in 'set' list of
  actions.
-}
class IsProp (prop :: PropertyKind)
  where
    -- | @performProp record prop @ performs an action on @record@ using @prop@.
    performProp :: (Monad m) => record -> prop m field record -> m ()

instance IsProp SetProp
  where
    performProp record (SetRecordPropM field   kl) = setRecords field record =<< kl record
    performProp record (SetRecordProp  field    f) = setRecords field record (f record)
    performProp record (SetPropM       field mval) = setRecords field record =<< mval
    performProp record (SetProp        field  val) = setRecords field record val

setRecords :: (Monad m, FieldSet field) => [field m record a] -> record -> a -> m ()
setRecords fields record val = forM_ fields $ \ field -> setRecord field record val

instance IsProp ModifyProp
  where
    performProp record (Modify      field f) = () <$ modifyRecords  field record (f record)
    performProp record (ModifyM     field f) = () <$ modifyRecordsM field record (f record)
    performProp record (ModifyProp  field f) = () <$ modifyRecords  field record f
    performProp record (ModifyPropM field f) = () <$ modifyRecordsM field record f

modifyRecords :: (Monad m, FieldModify field) =>
  [field m record b] -> record -> (b -> b) -> m ()
modifyRecords fields record f = fields `forM_` \ field -> modifyRecord field record f

modifyRecordsM :: (Monad m, FieldModify field, FieldGet field) =>
  [field m record b] -> record -> (b -> m b) -> m ()
modifyRecordsM fields record f = fields `forM_` \ field -> modifyRecordM field record f

instance IsProp SwitchProp
  where
    performProp record (SwitchProp n field) = switchRecord field record n

--------------------------------------------------------------------------------

-- | @since 0.2 Service kind synonym.
type FieldKind = (Type -> Type) -> Type -> Type -> Type

-- | @since 0.2 Service kind synonym.
type PropertyKind = (Type -> Type) -> FieldKind -> Type -> Type

--------------------------------------------------------------------------------

{- fmr classes. -}

-- | @since 0.2 Property getter class.
class FieldGet field
  where
    -- | @'getRecord' field record@ return @record@'s value using @field@.
    getRecord :: (Monad m) => field m record a -> record -> m a

-- | @since 0.2 Property setter class.
class FieldSet field
  where
    -- | @'setRecord' field record value@ sets new @record@ @value@.
    setRecord :: (Monad m) => field m record a -> record -> a -> m ()

{- |
  @since 0.2
  Property modifier class.
  
  Note that 'FieldModifier' doesn't go well with write-only fields, because
  'modifyRecord' returns new value, and 'modifyRecordM' also assumes the
  possibility of old value \"leaking\" (hence the 'FieldGet' constraint is
  imposed on it).
-}
class (FieldSet field) => FieldModify field
  where
    {- |
      @'modifyRecord' field record upd@ modifies @record@ @field@ using @upd@.
      Returns new value.
    -}
    default modifyRecord :: (Monad m, FieldGet field) =>
      field m record a -> record -> (a -> a) -> m a
    modifyRecord :: (Monad m) => field m record a -> record -> (a -> a) -> m a
    modifyRecord field record f = do
      val <- f <$> get field record
      setRecord field record val
      return val
    
    {- |
      @'modifyRecordM' field record upd@ modifies @record@ @field@ using @upd@.
      Note that assumes the possibility of old value \"leaking\", e.g.:
      
      @
        -- get value using 'modifyRecordM'
        getLeak = do
          -- Some read-only fields
          x <- newWriteOnly
          y <- 'var' Nothing
          -- write current value to y and do not modify.
          modifyRecordM this x (\ val -> do set [this := Just val]; return val)
          -- leaking: return current value of "write-only" record
          get this y
      @
      
      So you cannot use it for write-only fields.
    -}
    modifyRecordM :: (Monad m, FieldGet field) =>
      field m record a -> record -> (a -> m a) -> m a
    modifyRecordM field record f = do
      val <- f =<< get field record
      setRecord field record val
      return val

{- |
  Switch property modifier.
  
  Note that 'FieldSwitch' is designed for deterministic switches with a
  pre-known set of states and order of transitions between them, without
  branches. If you need more complex behavior, use 'FieldModify'.
-}
class FieldSwitch field
  where
    -- | Repeated increment or decrement.
    switchRecord :: (Monad m, IsSwitch a) => field m record a -> record -> Int -> m ()

--------------------------------------------------------------------------------

{- fmr properties. -}

{- |
  @since 0.2
  'SetProp' is a service type used to set field values.
  See @(':=')@, @(':=$')@, @('::=')@, @('::=$')@, @(':<=')@, @(':<=$')@,
  @(':=<')@ and @(':=<$')@ patterns.
-}
data SetProp m field record
  where
    -- | 'SetProp' corresponds to @(':=$')@ and @(':=')@.
    SetProp :: (FieldSet field) =>
      [field m record a] -> a -> SetProp m field record
    
    -- | 'SetPropM' corresponds to @('::=$')@ and @('::=')@.
    SetPropM :: (FieldSet field) =>
      [field m record a] -> m a -> SetProp m field record
    
    -- | 'SetRecordProp' corresponds to @(':<=$')@ and @(':<=')@.
    SetRecordProp :: (FieldSet field) =>
      [field m record a] -> (record -> a) -> SetProp m field record
    
    -- | 'SetRecordPropM' corresponds to @(':=<$')@ and @(':=<')@.
    SetRecordPropM :: (FieldSet field) =>
      [field m record a] -> (record -> m a) -> SetProp m field record
  deriving ( Typeable )

{- |
  @since 0.2
  'ModifyProp' is a service type used to modify field values.
  See @(':~')@, @(':~$')@, @(':<~')@, @(':<~$')@, @('::~')@, @('::~$')@,
  @(':~<')@, @(':~<$')@ patterns.
-}
data ModifyProp m field record
  where
    -- | 'FieldModify' constructor corresponds to @(':~$')@ and @(':~')@.
    ModifyProp :: (FieldModify field) =>
      [field m record a] -> (a -> a) -> ModifyProp m field record
    
    -- | 'FieldModify' constructor corresponds to @(':<~$')@ and @(':<~')@.
    ModifyPropM :: (FieldModify field, FieldGet field) =>
      [field m record a] -> (a -> m a) -> ModifyProp m field record
    
    -- | 'Modify' constructor corresponds to @('::~$')@ and @('::~')@.
    Modify :: (FieldModify field) =>
      [field m record a] -> (record -> a -> a) -> ModifyProp m field record
    
    -- | 'ModifyM' constructor corresponds to @(':~<$')@ and @(':~<')@.
    ModifyM :: (FieldModify field, FieldGet field) =>
      [field m record a] -> (record -> a -> m a) -> ModifyProp m field record
  deriving ( Typeable )

{- |
  @since 0.2
  'SwitchProp' is a service type used to update record values, see 'switch',
  'incr' and 'decr'.
-}
data SwitchProp m field record
  where
    -- | Switch field, see 'switch', 'incr' and 'decr'.
    SwitchProp :: (Monad m, FieldSwitch field, IsSwitch a) =>
      Int -> field m record a -> SwitchProp m field record
  deriving ( Typeable )

--------------------------------------------------------------------------------

{- fmr pure setters. -}

{- |
  Pure value setter. @set record [field := value]@ set @value@ to @record@'s
  @field@.
-}
pattern (:=) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => field m record a -> a -> Prop m field record
pattern field := val = [field] :=$ val

{- |
  Pure value setter with @record@. @set record [field ::= f]@ set @f record@ to
  @record@'s @field@.
  
  @
    set record [field ::= const val] === set record [field := val]
  @
-}
pattern (::=) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => field m record a -> (record -> a) -> Prop m field record
pattern field ::= f = [field] ::=$ f

{- |
  @since 0.2
  Pure group setter. @set record [fields :=$ value]@ set @value@ to @record@'s
  some @fields@.
  
  @
    set record [[field] :=$ value] === set record [field := value]
  @
-}
pattern (:=$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => [field m record a] -> a -> Prop m field record
pattern field :=$ val <- (cast -> Just (SetProp field val))
  where
    (:=$) = Prop ... SetProp

{- |
  @since 0.2
  Pure group setter with @record@. @set record [fields ::=$ f]@ set @f record@
  to @record@'s some @fields@.
  
  @
    set record [[field] ::=$ f] === set record [field ::= f]
    set record [fields ::=$ const val] === set record [fields :=$ val]
  @
-}
pattern (::=$) ::
  (
    Typeable m, Typeable field, Typeable record, Monad m, FieldSet field
  ) => [field m record a] -> (record -> a) -> Prop m field record
pattern field ::=$ f <- (cast -> Just (SetRecordProp field f))
  where
    (::=$) = Prop ... SetRecordProp

--------------------------------------------------------------------------------

{- fmr pure updaters. -}

{- |
  Pure value modifier. @set record [field :~ f]@ modify value of @record@'s
  @field@ using @f@ function.
  
  @
    set record [field :~ const val] === set record [field := val]
  @
-}
pattern (:~) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field
  ) => field m record a -> (a -> a) -> Prop m field record
pattern field :~ f = [field] :~$ f

{- |
  Pure value modifier with @record@. @set record [field ::~ f]@ modify value of
  @record@'s @field@ using @f record@ function.
  
  @
    set record [field ::~ const f] === set record [field :~ f]
  @
-}
pattern (::~) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field
  ) => field m record a -> (record -> a -> a) -> Prop m field record
pattern field ::~ f = [field] ::~$ f

{- |
  @since 0.2
  Pure group modifier. @set record [fields :~$ f]@ modify values of @record@'s
  @fields@ using @f@ function.
  
  @
    set record [[field] :~$ val] === set record [field :~ val]
    set record [fields :~$ const val] === set record [field :=$ val]
  @
-}
pattern (:~$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field
  ) => [field m record a] -> (a -> a) -> Prop m field record
pattern field :~$ f <- (cast -> Just (ModifyProp field f))
  where
    (:~$) = Prop ... ModifyProp

{- |
  @since 0.2
  Pure group modifier with @record@.
  @set record [fields ::~$ f]@ modify values of @record@'s @fields@ using
  @f record@ function.
  
  @
    set record [[field] ::~$ f] === set record [field ::~ f]
    set record [fields ::~$ const f] === set record [field :~$ f]
  @
-}
pattern (::~$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field
  ) => [field m record a] -> (record -> a -> a) -> Prop m field record
pattern field ::~$ f <- (cast -> Just (Modify field f))
  where
    (::~$) = Prop ... Modify

--------------------------------------------------------------------------------

{- fmr monadic setters. -}

{- |
  @since 0.2
  Monadic value setter. @set record [field :<= mvalue]@ set result of @mvalue@
  to @record@'s @field@. Note that the @mvalue@ is evaluated every time a
  @field@ value is assigned.
  
  @
    set record [field :<= return val] === set record [field := val]
    set record [field :<= mval] === do val <- mval; set record [field :<= val]
  @
-}
pattern (:<=) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => field m record a -> m a -> Prop m field record
pattern field :<= mval = [field] :<=$ mval

{- |
  @since 0.2
  Monadic value setter with @record@. @set record [field :=< mvalue]@ set result
  of @mvalue record@ to @record@'s @field@. Note that the @mvalue@ is evaluated
  every time a @field@ value is assigned.
  
  @
    set record [field :=< const val] === set record [field :<= val]
    set record [field :=< f] === do val <- f record; set record [field := val]
  @
-}
pattern (:=<) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => field m record a -> (record -> m a) -> Prop m field record
pattern field :=< f = [field] :=<$ f

{- |
  @since 0.2
  Monadic group setter. @set record [fields :<=$ mvalue]@ set result of @mvalue@
  to @record@'s @fields@. Note that @mvalue@ is evaluated only once, on the
  first assignment. Thus, the values of all the listed fields will be identical.
  
  @
    set record [[field] :<=$ const f] === set record [field :<= val]
    set record [fields :<=$ mval] === do val <- mval; set record [fields :<=$ val]
  @
-}
pattern (:<=$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => [field m record a] -> m a -> Prop m field record
pattern field :<=$ mval <- (cast -> Just (SetPropM field mval))
  where
    (:<=$) = Prop ... SetPropM

{- |
  @since 0.2
  Monadic group setter with @record@. @set record [fields :=<$ f]@ set result of
  @f record@ to @record@'s @fields@. Note that @f record@ is evaluated only
  once, on the first assignment. Thus, the values of all the listed fields will
  be identical.
  
  @
    set record [[field] :=<$ f] === set record [field :=< val]
    set record [fields :=<$ const val] = set record [fields :=$ val]
    set record [fields :=<$ f] === do val <- f record; set record [fields :=$ val]
  @
-}
pattern (:=<$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldSet field
  ) => [field m record a] -> (record -> m a) -> Prop m field record
pattern field :=<$ f <- (cast -> Just (SetRecordPropM field f))
  where
    (:=<$) = Prop ... SetRecordPropM

--------------------------------------------------------------------------------

{- fmr monadic updaters. -}

{- |
  @since 0.2
  Monadic value modifier. @set record [field :<~ f]@ modifies value of
  @record@'s @field@ using @f@ procedure. Note that the @mvalue@ is called every
  time a @field@ value is assigned.
  
  @
    set record [field :<~ return val] === set record [fields := val]
  @
-}
pattern (:<~) ::
  (
    Typeable m, Typeable field, Typeable record, Monad m,
    FieldModify field, FieldGet field
  ) => field m record a -> (a -> m a) -> Prop m field record
pattern field :<~ f = [field] :<~$ f

{- |
  @since 0.2
  Monadic value modifier with @record@. @set record [field :<~ f]@ modifies
  value of @record@'s @field@ using @f record@ procedure. Note that the
  @f record@ is called every time a @field@ value is assigned.
  
  @
    set record [field :~< const f] === set record [fields :<~ f]
  @
-}
pattern (:~<) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field, FieldGet field
  ) => field m record a -> (record -> a -> m a) -> Prop m field record
pattern field :~< f = [field] :~<$ f

{- |
  @since 0.2
  Monadic group modifier. @set record [fields :<~$ f]@ modifies values of
  @record@'s @fields@ using @f@ procedure.
  
  @
    set record [[field] :<~$ f] === set record [field :<~ f]
    set record [fields :<~$ const mval] === set record [field :<=$ mval]
  @
-}
pattern (:<~$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field, FieldGet field
  ) => [field m record a] -> (a -> m a) -> Prop m field record
pattern field :<~$ f <- (cast -> Just (ModifyPropM field f))
  where
    (:<~$) = Prop ... ModifyPropM

{- |
  @since 0.2
  Monadic group modifier with @record@. @set record [fields :~<$ f]@ modifies
  values of @record@'s @fields@ using @f record@ procedure. Note that the
  @f record@ is called every time a @field@ value is assigned.
  
  @
    set record [field :~<$ const f] === set record [fields :<~$ f]
  @
-}
pattern (:~<$) ::
  (
    Typeable m, Typeable field, Typeable record,
    Monad m, FieldModify field, FieldGet field
  ) => [field m record a] -> (record -> a -> m a) -> Prop m field record
pattern field :~<$ f <- (cast -> Just (ModifyM field f))
  where
    (:~<$) = Prop ... ModifyM

--------------------------------------------------------------------------------

-- | Service class for switchable types.
class IsSwitch switch
  where
    {- |
      @'toggle' s n@ "toggles" the state represented by the value @s@ by @n@
      positions, for example:
      
      @
        toggle n False = even n
        toggle n  True = odd  n
        toggle n  1234 = 1239 + n
      @
    -}
    toggle :: Int -> switch -> switch

instance IsSwitch Bool
  where
    toggle n False = even n
    toggle n  True = odd  n

instance (Integral i) => IsSwitch i where toggle n i = fromIntegral n + i

--------------------------------------------------------------------------------

-- | The 'get' function reads current value of a field.
get :: (Monad m, FieldGet field) => field m record a -> record -> m a
get =  getRecord

-- | @'gets'' fields record@ returns list of @record@ @fields@ values.
gets' :: (Monad m, FieldGet field) => record -> [field m record a] -> m [a]
gets' =  mapM . flip getRecord

{- |
  'set' is the main function in @fmr@, which allows you to describe changing the
  value of a record as a sequence of operations on its fields, e.g.
-}
set :: (Monad m) => record -> [Prop m field record] -> m ()
set record = mapM_ $ \ (Prop prop) -> performProp record prop

-- | Just synonym for 'set'.
sets' :: (Monad m) => record -> [Prop m field record] -> m ()
sets' =  set

-- | 'switch' changes the value by n steps.
switch :: (Monad m, FieldSwitch field, IsSwitch a) =>
  field m record a -> Int -> Prop m field record
switch field n = Prop (SwitchProp n field)

-- | @'incr' field@ is same as @switch field 1@.
incr :: (Monad m, FieldSwitch field, IsSwitch a) =>
  field m record a -> Prop m field record
incr =  Prop . SwitchProp 1

-- | @'decr' field@ is same as @switch field (-1)@.
decr :: (Monad m, FieldSwitch field, IsSwitch a) =>
  field m record a -> Prop m field record
decr =  Prop . SwitchProp (-1)

--------------------------------------------------------------------------------

-- | @sdp@ @(.)@-like combinator.
(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(...) =  (.) . (.)