-- 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 (.., (:!), (:?), N, M, SomeArg, NoArg)
  , Name
  , arg
  , argF
  , argDef
  ) where

import Debug qualified (show)

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

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 $b:! :: Name name -> a -> NamedF Identity a name
$m:! :: forall r (name :: Symbol) a.
NamedF Identity a name
-> (Name name -> a -> r) -> (Void# -> r) -> r
(:!) n v <- ((Name,) -> (n, ArgF (Identity v)))
  where (:!) Name name
_ a
v = Identity a -> NamedF Identity a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF (a -> Identity a
forall a. a -> Identity a
Identity a
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 $b:? :: Name name -> Maybe a -> NamedF Maybe a name
$m:? :: forall r (name :: Symbol) a.
NamedF Maybe a name
-> (Name name -> Maybe a -> r) -> (Void# -> r) -> r
(:?) n v <- ((Name,) -> (n, ArgF v))
  where (:?) Name name
_ Maybe a
v = Maybe a -> NamedF Maybe a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF Maybe a
v
{-# COMPLETE (:?) #-}

-- | Convenience pattern synonym, use this instead of 'Named.arg' with @ViewPatterns@
-- when the @name@ can be inferred.
pattern N :: a -> NamedF Identity a name
pattern $bN :: a -> NamedF Identity a name
$mN :: forall r a (name :: Symbol).
NamedF Identity a name -> (a -> r) -> (Void# -> r) -> r
N a = ArgF (Identity a)
{-# COMPLETE N #-}
{-# DEPRECATED N "Please use view patterns with 'arg' instead." #-}

-- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@
-- when the @name@ can be inferred. Matches only on @Just@ values
pattern SomeArg :: a -> NamedF Maybe a name
pattern $bSomeArg :: a -> NamedF Maybe a name
$mSomeArg :: forall r a (name :: Symbol).
NamedF Maybe a name -> (a -> r) -> (Void# -> r) -> r
SomeArg a = ArgF (Just a)

-- | Convenience pattern synonym, use this instead of 'Named.argF' with @ViewPatterns@
-- when the @name@ can be inferred. Matches only on @Nothing@ values
pattern NoArg :: NamedF Maybe a name
pattern $bNoArg :: NamedF Maybe a name
$mNoArg :: forall r a (name :: Symbol).
NamedF Maybe a name -> (Void# -> r) -> (Void# -> r) -> r
NoArg = ArgF Nothing
{-# COMPLETE NoArg, SomeArg #-}

-- | Convenience pattern synonym for @NamedF Maybe name a@, use this instead of 'Named.argF' with @ViewPatterns@
-- when the @name@ can be inferred.
pattern M :: Maybe a -> NamedF Maybe a name
pattern $bM :: Maybe a -> NamedF Maybe a name
$mM :: forall r a (name :: Symbol).
NamedF Maybe a name -> (Maybe a -> r) -> (Void# -> r) -> r
M a = ArgF a
{-# COMPLETE M #-}
{-# DEPRECATED M, SomeArg, NoArg "Please use view patterns with 'argF' instead." #-}

-- | Special version of 'Morley.Util.Named.(:!)' for monadic operations
(<:!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)
<:!> :: Name name -> m a -> m (NamedF Identity a name)
(<:!>) Name name
name = (a -> NamedF Identity a name) -> m a -> m (NamedF Identity a name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name name
name Name name -> a -> NamedF Identity a name
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a 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 name -> m (Maybe a) -> m (NamedF Maybe a name)
(<:?>) Name name
name = (Maybe a -> NamedF Maybe a name)
-> m (Maybe a) -> m (NamedF Maybe a name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name name
name Name name -> Maybe a -> NamedF Maybe a name
forall (name :: Symbol) a.
Name name -> Maybe a -> NamedF Maybe a 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 :: Label name -> Iso' (NamedF f a name) (f a)
namedFL Label name
_ = (NamedF f a name -> f a)
-> (f a -> NamedF f a name) -> Iso' (NamedF f a name) (f a)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(ArgF f a
x) -> f a
x) f a -> NamedF f a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
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 :: Label name
-> Iso' (NamedF Identity a name) (ApplyNamedFunctor Identity a)
namedL Label name
l = Label name -> Iso' (NamedF Identity a name) (Identity a)
forall (name :: Symbol) (f :: * -> *) a.
Label name -> Iso' (NamedF f a name) (f a)
namedFL Label name
l (p (Identity a) (f (Identity a))
 -> p (NamedF Identity a name) (f (NamedF Identity a name)))
-> (p a (f a) -> p (Identity a) (f (Identity a)))
-> p a (f a)
-> p (NamedF Identity a name) (f (NamedF Identity a name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f a) -> p (Identity a) (f (Identity a))
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'

instance KnownNamedFunctor Maybe where
  namedL :: Label name
-> Iso' (NamedF Maybe a name) (ApplyNamedFunctor Maybe a)
namedL Label name
l = Label name -> Iso' (NamedF Maybe a name) (Maybe a)
forall (name :: Symbol) (f :: * -> *) a.
Label name -> Iso' (NamedF f a name) (f a)
namedFL Label name
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
  show :: NamedF Identity a name -> String
show (ArgF Identity a
a) = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :! " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Identity a -> String
forall b a. (Show a, IsString b) => a -> b
Debug.show Identity a
a

instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where
  build :: NamedF f a name -> Builder
build (ArgF f a
a) = String -> Builder
forall p. Buildable p => p -> Builder
build (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> f a -> Builder
forall p. Buildable p => p -> Builder
build f a
a

instance (NFData (f a)) => NFData (NamedF f a name) where
  rnf :: NamedF f a name -> ()
rnf (ArgF f a
a) = f a -> ()
forall a. NFData a => a -> ()
rnf f a
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)