{-# LANGUAGE AllowAmbiguousTypes, DataKinds, ExplicitNamespaces,
             FunctionalDependencies, PatternSynonyms, TypeFamilies,
             UndecidableInstances #-}

module Named.Internal where

import Prelude (id, Maybe(..))
import Data.Maybe (fromMaybe)
import Data.Functor.Identity (Identity(..))
import Data.Kind (Type)
import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
import GHC.OverloadedLabels (IsLabel(..))
import Data.Type.Equality (type (~))

{- |

Assign a name to a value of type @a@ wrapped in @f@.

@
#verbose True :: NamedF Identity Bool "verbose"
@

-}
newtype NamedF f (a :: Type) (name :: Symbol) =
  ArgF (f a) -- ^ Match on an F-argument without specifying its name.
             -- See also: 'argF'.

-- | Match on an argument without specifying its name. See also: 'arg'.
pattern Arg :: a -> name :! a
pattern $mArg :: forall {r} {a} {name :: Symbol}.
(name :! a) -> (a -> r) -> ((# #) -> r) -> r
$bArg :: forall a (name :: Symbol). a -> name :! a
Arg a = ArgF (Identity a)
{-# COMPLETE Arg #-}

-- | Infix notation for the type of a named parameter.
type name :! a = NamedF Identity a name

-- | Infix notation for the type of an optional named parameter.
type name :? a = NamedF Maybe a name

class InjValue f where
  injValue :: a -> f a

instance InjValue Identity where
  injValue :: forall a. a -> Identity a
injValue = a -> Identity a
forall a. a -> Identity a
Identity

instance InjValue Maybe where
  injValue :: forall a. a -> Maybe a
injValue = a -> Maybe a
forall a. a -> Maybe a
Just

instance (name ~ name', a ~ a', InjValue f) => IsLabel name (a -> NamedF f a' name') where
  fromLabel :: a -> NamedF f a' name'
fromLabel a
a = f a' -> NamedF f a' name'
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF (a' -> f a'
forall a. a -> f a
forall (f :: * -> *) a. InjValue f => a -> f a
injValue a
a'
a)
  {-# INLINE fromLabel #-}

newtype Param p = Param p

instance (p ~ NamedF f a name, InjValue f) => IsLabel name (a -> Param p) where
  fromLabel :: a -> Param p
fromLabel a
a = p -> Param p
forall p. p -> Param p
Param (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @name a
a)
  {-# INLINE fromLabel #-}

{- | Explicitly build a function parameter:

@
fn '!' 'param' \#param_name value
@

This is equivalent to the implicit notation:

@
fn '!' \#param_name value
@

-}
param :: Name name -> a -> Param (name :! a)
param :: forall (name :: Symbol) a. Name name -> a -> Param (name :! a)
param Name name
_ a
a = (name :! a) -> Param (name :! a)
forall p. p -> Param p
Param (a -> name :! a
forall a (name :: Symbol). a -> name :! a
Arg a
a)

{- | Explicitly build a function parameter inside an arity wrapper:

@
fn '!' 'paramF' \#param_name ('Identity' value)
fn '!' 'paramF' \#param_name ('Just' value)
fn '!' 'paramF' \#param_name 'Nothing'
@

This has no equivalent implicit notation.

-}
paramF :: Name name -> f a -> Param (NamedF f a name)
paramF :: forall (name :: Symbol) (f :: * -> *) a.
Name name -> f a -> Param (NamedF f a name)
paramF Name name
_ f a
fa = NamedF f a name -> Param (NamedF f a name)
forall p. p -> Param p
Param (f a -> NamedF f a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF f a
fa)

{- | Supply a parameter to a function:

@
function '!' \#param_name value
@

@
function '!' \#x 7 '!' #y 42 '!' 'defaults'
@

This is an infix version of 'with'.

-}
(!) :: forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
fn
fn ! :: forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn'
! Param p
p = Param p -> fn -> fn'
forall p fn fn'. WithParam p fn fn' => Param p -> fn -> fn'
with Param p
p fn
fn
{-# INLINE (!) #-}

infixl 9 !

{- |
Supply a parameter @p@ to a function @fn@, resulting in @fn'@.

For example, when we pass a single named parameter, we get a function without
this parameter:

@
WithParam
                 ("x" :! Char)       -- p
  ("b" :! Bool -> "x" :! Char -> r)  -- fn
  ("b" :! Bool                -> r)  -- fn'
@

In case the parameter cannot be supplied, this constraint will become a type
error.

-}
class WithParam p fn fn' | p fn -> fn' where
  {- | Supply a parameter to a function:

  @
  'with' (\#param_name value) function
  @

  @
  'with' 'defaults' function
  @

  This is a prefix version of the ('!') operator.

  -}
  with :: Param p -> fn -> fn'

instance WithParam' (Decide p fn) p fn fn' => WithParam p fn fn' where
  with :: Param p -> fn -> fn'
with (Param p
p) fn
fn = forall (ds :: [*]) p fn fn'.
WithParam' ds p fn fn' =>
p -> fn -> fn'
withParam @(Decide p fn) p
p fn
fn
  {-# INLINE with #-}

data Defaults = Defaults

{- |
Passing 'defaults' to a function fills all unspecified optional parameters
with 'Nothing':

@
fn            :: "b" ':!' Bool -> "x" ':?' Char -> Int -> IO ()
fn '!' 'defaults' :: "b" ':!' Bool ->                Int -> IO ()
@

-}
defaults :: Param Defaults
defaults :: Param Defaults
defaults = Defaults -> Param Defaults
forall p. p -> Param p
Param Defaults
Defaults

{- |

A proxy for a name, intended for use with @-XOverloadedLabels@:

@
#verbose :: Name "verbose"
@

-}

data Name (name :: Symbol) = Name

instance name ~ name' => IsLabel name' (Name name) where
  fromLabel :: Name name
fromLabel = Name name
forall (name :: Symbol). Name name
Name
  {-# INLINE fromLabel #-}

{- |

'arg' unwraps a named parameter with the specified name. One way to use it is
to match on arguments with @-XViewPatterns@:

@
fn (arg \#t -> t) (arg \#f -> f) = ...
@

This way, the names of parameters can be inferred from the patterns: no type
signature for @fn@ is required. In case a type signature for @fn@ is
provided, the parameters must come in the same order:

@
fn :: "t" :! Integer -> "f" :! Integer -> ...
fn (arg \#t -> t) (arg \#f -> f) = ... -- ok
fn (arg \#f -> f) (arg \#t -> t) = ... -- does not typecheck
@

-}
arg :: Name name -> name :! a -> a
arg :: forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg Name name
_ (ArgF (Identity a
a)) = a
a
{-# INLINE arg #-}

{- |

'argF' is similar to 'arg': it unwraps a named parameter with the specified name.
The difference is that the result of 'argF' is inside an arity wrapper,
which is 'Identity' for normal parameters and 'Maybe' for optional parameters.

-}
argF :: Name name -> NamedF f a name -> f a
argF :: forall (name :: Symbol) (f :: * -> *) a.
Name name -> NamedF f a name -> f a
argF Name name
_ (ArgF f a
fa) = f a
fa
{-# INLINE argF #-}

{- |

A variation of 'arg' for optional arguments. Requires a default value to handle
the case when the optional argument was omitted:

@
fn (argDef \#answer 42 -> ans) = ...
@

In case you want to get a value wrapped in 'Maybe' instead, use 'argF' or
'ArgF'.

-}
argDef :: Name name -> a -> name :? a -> a
argDef :: forall (name :: Symbol) a. Name name -> a -> (name :? a) -> a
argDef Name name
_ a
d (ArgF Maybe a
fa) = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
d Maybe a
fa

--------------------------------------------------------------------------------
-- The working horses of the library: Decide and WithParam'
--------------------------------------------------------------------------------

data DApply
data DFill
data DPass

type family Decide (p :: Type) (fn :: Type) :: [Type] where
  Decide (NamedF f' a' name) (NamedF f a name -> r) = '[DApply]
  Decide Defaults (NamedF Maybe a name -> r) = DFill : Decide Defaults r
  Decide p (x -> r) = DPass : Decide p r
  Decide (NamedF f' a' name) t =
    TypeError (Text "Named parameter '" :<>: Text name :<>:
               Text "' was supplied, but not expected")
  Decide Defaults t = '[]

class WithParam' (ds :: [Type]) p fn fn' | ds p fn -> fn' where
  withParam :: p -> fn -> fn'

instance fn ~ fn' => WithParam' '[] p fn fn' where
  withParam :: p -> fn -> fn'
withParam p
_ = fn -> fn
fn -> fn'
forall a. a -> a
id
  {-# INLINE withParam #-}

instance
    ( WithParam' ds p r r',
      fn ~ (p -> r),
      fn' ~ r'
    ) => WithParam' (DApply : ds) p fn fn'
  where
    withParam :: p -> fn -> fn'
withParam p
p fn
fn = forall (ds :: [*]) p fn fn'.
WithParam' ds p fn fn' =>
p -> fn -> fn'
withParam @ds p
p (fn
p -> r
fn p
p)
    {-# INLINE withParam #-}

instance
    ( WithParam' ds p r r',
      fn ~ (x -> r),
      fn' ~ (x -> r')
    ) => WithParam' (DPass : ds) p fn fn'
  where
    withParam :: p -> fn -> fn'
withParam p
a fn
fn = \x
x -> forall (ds :: [*]) p fn fn'.
WithParam' ds p fn fn' =>
p -> fn -> fn'
withParam @ds p
a (fn
x -> r
fn x
x)
    {-# INLINE withParam #-}

instance
    ( WithParam' ds p r r',
      fn ~ (NamedF f x name -> r),
      fn' ~ r',
      f ~ Maybe
    ) => WithParam' (DFill : ds) p fn fn'
  where
    withParam :: p -> fn -> fn'
withParam p
p fn
fn = forall (ds :: [*]) p fn fn'.
WithParam' ds p fn fn' =>
p -> fn -> fn'
withParam @ds p
p (fn
NamedF Maybe x name -> r
fn (Maybe x -> NamedF Maybe x name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF Maybe x
forall a. Maybe a
Nothing))
    {-# INLINE withParam #-}