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


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 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 (:?) #-}

-- | 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 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 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 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 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 = 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)