Named.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Additional functionality for @named@ package.
module Morley.Util.Named
  ( (!)
  , (:!)
  , (:?)
  , (<:!>)
  , (<:?>)
  , ApplyNamedFunctor
  , NamedInner
  , KnownNamedFunctor (..)
  , NamedF (.., (:!), (:?))
  , Name
  , arg
  , argF
  , argDef
  ) where


import Control.Lens (Iso', Wrapped(..), iso)
import Data.Aeson (FromJSON, ToJSON)
import Data.Data (Data)
import Data.Default (Default(..))
import Fmt (Buildable(..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Named (Name(..), NamedF(..), arg, argDef, argF, defaults, (!), (:!), (:?))
import Named.Internal (Defaults, Param)
import Text.Show qualified as T

import Morley.Util.Label (Label)

{- | Convenience pattern synonym. Use to construct a named value.

To pattern-match on a named value, use 'arg' in a view pattern:

>>> :{
let someFunc (arg #arg1 -> arg1) (arg #arg2 -> arg2) = arg1 + arg2
in someFunc ! #arg1 1 ! #arg2 2
:}
3
-}
pattern (:!) :: Name name -> a -> NamedF Identity a name
pattern (:!) n v <- ((Name,) -> (n, ArgF (Identity v)))
  where (:!) _ v = ArgF (Identity v)
{-# COMPLETE (:!) #-}

{- | Convenience pattern synonym. Use to construct an optional named value.

To pattern-match on an optional named value, use 'argDef' or 'argF' in a view
pattern:

>>> :{
let someFunc (argDef #arg1 "" ->arg1) (argDef #arg2 "" -> arg2) = arg1 <> arg2
in someFunc ! #arg1 "asd" ! #arg2 "efg"
:}
"asdefg"
-}
pattern (:?) :: Name name -> Maybe a -> NamedF Maybe a name
pattern (:?) n v <- ((Name,) -> (n, ArgF v))
  where (:?) _ v = ArgF v
{-# COMPLETE (:?) #-}

-- | Special version of 'Morley.Util.Named.(:!)' for monadic operations
(<:!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)
(<:!>) name = fmap (name :!)
infixl 4 <:!>

-- | Special version of 'Morley.Util.Named.(:?)' for monadic operations
(<:?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)
(<:?>) name = fmap (name :?)
infixl 4 <:?>

type family ApplyNamedFunctor (f :: Type -> Type) (a :: Type) where
  ApplyNamedFunctor Identity a = a
  ApplyNamedFunctor Maybe a = Maybe a

type family NamedInner (n :: Type) where
  NamedInner (NamedF f a _) = ApplyNamedFunctor f a

-- | Isomorphism between named entity and the entity itself wrapped into the
-- respective functor.
namedFL :: Label name -> Iso' (NamedF f a name) (f a)
namedFL _ = iso (\(ArgF x) -> x) ArgF

class KnownNamedFunctor f where
  -- | Isomorphism between named entity and the entity itself.
  namedL :: Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)

instance KnownNamedFunctor Identity where
  namedL l = namedFL l . _Wrapped'

instance KnownNamedFunctor Maybe where
  namedL l = namedFL l

----------------------------------------------------------------------------
-- Instances
----------------------------------------------------------------------------

deriving stock instance Eq (f a) => Eq (NamedF f a name)
deriving stock instance Ord (f a) => Ord (NamedF f a name)

instance (Show a, KnownSymbol name) => Show (NamedF Identity a name) where
  showsPrec d (ArgF (Identity a)) = T.showParen (d > app_prec) $
    T.showString "fromLabel @" . T.shows (symbolVal (Proxy @name)) .
    T.showString " :! " . T.showsPrec (bang_prec + 1) a
    where
      app_prec = 10
      -- precedence of (:!)
      bang_prec = 9

instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where
  build (ArgF a) = build (symbolVal (Proxy @name)) <> ": " <> build a

instance (NFData (f a)) => NFData (NamedF f a name) where
  rnf (ArgF a) = rnf a

deriving stock instance
  (Typeable f, Typeable a, KnownSymbol name, Data (f a)) =>
  Data (NamedF f a name)

deriving newtype instance ToJSON a => ToJSON (NamedF Identity a name)
deriving newtype instance ToJSON a => ToJSON (NamedF Maybe a name)
deriving newtype instance FromJSON a => FromJSON (NamedF Identity a name)
deriving newtype instance FromJSON a => FromJSON (NamedF Maybe a name)

instance f ~ Defaults => Default (Param f) where
  def = defaults