--   This Source Code Form is subject to the terms of the Mozilla Public
--   License, v. 2.0. If a copy of the MPL was not distributed with this
--   file, You can obtain one at http://mozilla.org/MPL/2.0/.

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Support for simple sum types.
module Libjwt.Flag
  ( Flag(..)
  , AFlag(..)
  )
where

import           Libjwt.ASCII

import           Control.Applicative            ( (<|>) )

import           Data.Char                      ( toLower )
import           Data.Coerce                    ( coerce )

import           Data.Proxied                   ( conNameProxied )

import           Data.Proxy

import           GHC.Generics
import           GHC.TypeLits

import           Text.Casing

-- | Value that is encoded and decoded as 'AFlag'
--
--   Flags provide a way to automatically encode and decode simple sum types.
--
-- @
-- data Scope = Login | Extended | UserRead | UserWrite | AccountRead | AccountWrite
--  deriving stock (Show, Eq, Generic)
--
-- instance AFlag Scope
--
-- mkPayload = jwtPayload
--     (withIssuer "myApp" <> withRecipient "https://myApp.com" <> setTtl 300)
--     ( #user_name ->> "John Doe"
--     , #is_root ->> False
--     , #user_id ->> (12345 :: Int)
--     , #scope ->> Flag Login
--     )
-- @
newtype Flag a = Flag { Flag a -> a
getFlag :: a }
  deriving stock (Int -> Flag a -> ShowS
[Flag a] -> ShowS
Flag a -> String
(Int -> Flag a -> ShowS)
-> (Flag a -> String) -> ([Flag a] -> ShowS) -> Show (Flag a)
forall a. Show a => Int -> Flag a -> ShowS
forall a. Show a => [Flag a] -> ShowS
forall a. Show a => Flag a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag a] -> ShowS
$cshowList :: forall a. Show a => [Flag a] -> ShowS
show :: Flag a -> String
$cshow :: forall a. Show a => Flag a -> String
showsPrec :: Int -> Flag a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Flag a -> ShowS
Show, Flag a -> Flag a -> Bool
(Flag a -> Flag a -> Bool)
-> (Flag a -> Flag a -> Bool) -> Eq (Flag a)
forall a. Eq a => Flag a -> Flag a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag a -> Flag a -> Bool
$c/= :: forall a. Eq a => Flag a -> Flag a -> Bool
== :: Flag a -> Flag a -> Bool
$c== :: forall a. Eq a => Flag a -> Flag a -> Bool
Eq)

-- | Types that can be used as /flags/ . That is, they support conversion to/from ASCII values,
--   for example, simple sum types are good candidates that can even be generically derived
--
--
-- @
-- data Scope = Login | Extended | UserRead | UserWrite | AccountRead | AccountWrite
--  deriving stock (Show, Eq, Generic)
--
-- instance AFlag Scope
-- @
--
-- >>> getFlagValue UserWrite
-- ASCII {getASCII = "userWrite"}
--
-- >>> setFlagValue (ASCII "userWrite") :: Maybe Scope
-- Just UserWrite
class AFlag a where
  getFlagValue :: a -> ASCII
  default getFlagValue :: (Generic a, GFlag (Rep a)) => a -> ASCII
  getFlagValue = Rep a Any -> ASCII
forall (f :: * -> *) p. GFlag f => f p -> ASCII
ggetFlagValue (Rep a Any -> ASCII) -> (a -> Rep a Any) -> a -> ASCII
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

  setFlagValue :: ASCII -> Maybe a
  default setFlagValue :: (Generic a, GFlag (Rep a)) => ASCII -> Maybe a
  setFlagValue = (Rep a Any -> a) -> Maybe (Rep a Any) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Maybe (Rep a Any) -> Maybe a)
-> (ASCII -> Maybe (Rep a Any)) -> ASCII -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASCII -> Maybe (Rep a Any)
forall (f :: * -> *) p. GFlag f => ASCII -> Maybe (f p)
gsetFlagValue

instance AFlag a => AFlag (Flag a) where
  getFlagValue :: Flag a -> ASCII
getFlagValue = a -> ASCII
forall a. AFlag a => a -> ASCII
getFlagValue (a -> ASCII) -> (Flag a -> a) -> Flag a -> ASCII
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag a -> a
forall a. Flag a -> a
getFlag
  setFlagValue :: ASCII -> Maybe (Flag a)
setFlagValue = Maybe a -> Maybe (Flag a)
coerce (Maybe a -> Maybe (Flag a))
-> (ASCII -> Maybe a) -> ASCII -> Maybe (Flag a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AFlag a => ASCII -> Maybe a
forall a. AFlag a => ASCII -> Maybe a
setFlagValue @a

class GFlag f where
  ggetFlagValue :: f p -> ASCII
  gsetFlagValue :: ASCII -> Maybe (f p)

instance GFlag f => GFlag (D1 d f) where
  ggetFlagValue :: D1 d f p -> ASCII
ggetFlagValue (M1 f p
x) = f p -> ASCII
forall (f :: * -> *) p. GFlag f => f p -> ASCII
ggetFlagValue f p
x

  gsetFlagValue :: ASCII -> Maybe (D1 d f p)
gsetFlagValue = (f p -> D1 d f p) -> Maybe (f p) -> Maybe (D1 d f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> D1 d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe (f p) -> Maybe (D1 d f p))
-> (ASCII -> Maybe (f p)) -> ASCII -> Maybe (D1 d f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASCII -> Maybe (f p)
forall (f :: * -> *) p. GFlag f => ASCII -> Maybe (f p)
gsetFlagValue

instance (GFlag l, GFlag r) => GFlag (l :+: r) where
  ggetFlagValue :: (:+:) l r p -> ASCII
ggetFlagValue (L1 l p
x) = l p -> ASCII
forall (f :: * -> *) p. GFlag f => f p -> ASCII
ggetFlagValue l p
x
  ggetFlagValue (R1 r p
x) = r p -> ASCII
forall (f :: * -> *) p. GFlag f => f p -> ASCII
ggetFlagValue r p
x

  gsetFlagValue :: ASCII -> Maybe ((:+:) l r p)
gsetFlagValue ASCII
string = Maybe ((:+:) l r p)
forall (g :: * -> *) p. Maybe ((:+:) l g p)
tryL Maybe ((:+:) l r p) -> Maybe ((:+:) l r p) -> Maybe ((:+:) l r p)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ((:+:) l r p)
forall (f :: * -> *) p. Maybe ((:+:) f r p)
tryR
   where
    tryL :: Maybe ((:+:) l g p)
tryL = l p -> (:+:) l g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l p -> (:+:) l g p) -> Maybe (l p) -> Maybe ((:+:) l g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ASCII -> Maybe (l p)
forall (f :: * -> *) p. GFlag f => ASCII -> Maybe (f p)
gsetFlagValue ASCII
string
    tryR :: Maybe ((:+:) f r p)
tryR = r p -> (:+:) f r p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r p -> (:+:) f r p) -> Maybe (r p) -> Maybe ((:+:) f r p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ASCII -> Maybe (r p)
forall (f :: * -> *) p. GFlag f => ASCII -> Maybe (f p)
gsetFlagValue ASCII
string

instance Constructor c => GFlag (C1 c U1) where
  ggetFlagValue :: C1 c U1 p -> ASCII
ggetFlagValue C1 c U1 p
_ = String -> ASCII
ASCII (String -> ASCII) -> String -> ASCII
forall a b. (a -> b) -> a -> b
$ ShowS
conNameToFlagValue String
c
    where c :: String
c = Proxy (M1 C c U1 Any) -> String
forall k1 k2 (proxy :: * -> *) (t :: k1 -> (k2 -> *) -> k2 -> *)
       (c :: k1) (f :: k2 -> *) (a :: k2).
Constructor c =>
proxy (t c f a) -> String
conNameProxied (forall p. Proxy (C1 c U1 p)
forall k (t :: k). Proxy t
Proxy :: Proxy (C1 c U1 p))

  gsetFlagValue :: ASCII -> Maybe (C1 c U1 p)
gsetFlagValue (ASCII String
flag) = if ShowS
lower String
flag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ShowS
lower String
c
    then C1 c U1 p -> Maybe (C1 c U1 p)
forall a. a -> Maybe a
Just (U1 p -> C1 c U1 p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 p
forall k (p :: k). U1 p
U1)
    else Maybe (C1 c U1 p)
forall a. Maybe a
Nothing
   where
    lower :: ShowS
lower = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
    c :: String
c     = Proxy (M1 C c U1 Any) -> String
forall k1 k2 (proxy :: * -> *) (t :: k1 -> (k2 -> *) -> k2 -> *)
       (c :: k1) (f :: k2 -> *) (a :: k2).
Constructor c =>
proxy (t c f a) -> String
conNameProxied (forall p. Proxy (C1 c U1 p)
forall k (t :: k). Proxy t
Proxy :: Proxy (C1 c U1 p))

conNameToFlagValue :: String -> String
conNameToFlagValue :: ShowS
conNameToFlagValue = Identifier String -> String
toCamel (Identifier String -> String)
-> (String -> Identifier String) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromHumps

instance
  ( TypeError
    ( 'Text "Only sum types with empty constructors can be flags. For instance,"
      ':$$:
      'Text "data Good = A | B | C is ok, but"
      ':$$:
      'Text "data Bad = A Int String | B | C Char is not"
    )
  ) => GFlag (C1 c (any :*: thing)) where
  ggetFlagValue :: C1 c (any :*: thing) p -> ASCII
ggetFlagValue = String -> C1 c (any :*: thing) p -> ASCII
forall a. HasCallStack => String -> a
error String
"unreachable"
  gsetFlagValue :: ASCII -> Maybe (C1 c (any :*: thing) p)
gsetFlagValue = String -> ASCII -> Maybe (C1 c (any :*: thing) p)
forall a. HasCallStack => String -> a
error String
"unreachable"