{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Name
  ( type Name
  , Named
  , name, nameOf, nameProxy, styleProxy, caselessName
  , NameStyle, UTF8, CaseInsensitive, Secure
  , HasName, myName
  , NameText, nameText
  , SomeName(SomeName), viewSomeName
  , SomeNameStyle(SomeNameStyle), viewSomeNameStyle
  , SecureName, secureName, secureNameBypass
  , IsText(fromText)
  , ConvertName(convertName)
  , ConvertNameStyle(convertStyle)
  , ValidNames, validName
)
where

import           Control.DeepSeq ( NFData )
import           Data.Hashable ( Hashable )
import           Data.Proxy ( Proxy(Proxy) )
import           Data.String ( IsString(fromString) )
import           Data.Text ( Text )
import qualified Data.Text as T
import           GHC.Exts ( Proxy#, proxy#, IsList(fromList, toList), Item )
import           GHC.Generics ( Generic )
import           GHC.TypeLits
import           Prettyprinter ( (<+>) )
import qualified Prettyprinter as PP
import           Text.Sayable


-- | The 'Named' is a wrapper around any 'Text' that identifies the type of
-- 'Text' via the @sym@ phantom symbol type, as well as a usage specified by the
-- @style@ type parameter.  Use of 'Named' should always be preferred to using
-- a raw 'Text' (or 'String').

newtype Named (style :: NameStyle) (sym :: Symbol) =
  Named { forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named :: Text }
  deriving (Named style sym -> Named style sym -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
/= :: Named style sym -> Named style sym -> Bool
$c/= :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
== :: Named style sym -> Named style sym -> Bool
$c== :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
Eq, Named style sym -> Named style sym -> Bool
Named style sym -> Named style sym -> Ordering
Named style sym -> Named style sym -> Named style sym
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (style :: Symbol) (sym :: Symbol). Eq (Named style sym)
forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Ordering
forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Named style sym
min :: Named style sym -> Named style sym -> Named style sym
$cmin :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Named style sym
max :: Named style sym -> Named style sym -> Named style sym
$cmax :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Named style sym
>= :: Named style sym -> Named style sym -> Bool
$c>= :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
> :: Named style sym -> Named style sym -> Bool
$c> :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
<= :: Named style sym -> Named style sym -> Bool
$c<= :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
< :: Named style sym -> Named style sym -> Bool
$c< :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Bool
compare :: Named style sym -> Named style sym -> Ordering
$ccompare :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (style :: Symbol) (sym :: Symbol) x.
Rep (Named style sym) x -> Named style sym
forall (style :: Symbol) (sym :: Symbol) x.
Named style sym -> Rep (Named style sym) x
$cto :: forall (style :: Symbol) (sym :: Symbol) x.
Rep (Named style sym) x -> Named style sym
$cfrom :: forall (style :: Symbol) (sym :: Symbol) x.
Named style sym -> Rep (Named style sym) x
Generic, Named style sym -> ()
forall a. (a -> ()) -> NFData a
forall (style :: Symbol) (sym :: Symbol). Named style sym -> ()
rnf :: Named style sym -> ()
$crnf :: forall (style :: Symbol) (sym :: Symbol). Named style sym -> ()
NFData, NonEmpty (Named style sym) -> Named style sym
Named style sym -> Named style sym -> Named style sym
forall b. Integral b => b -> Named style sym -> Named style sym
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (style :: Symbol) (sym :: Symbol).
NonEmpty (Named style sym) -> Named style sym
forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Named style sym
forall (style :: Symbol) (sym :: Symbol) b.
Integral b =>
b -> Named style sym -> Named style sym
stimes :: forall b. Integral b => b -> Named style sym -> Named style sym
$cstimes :: forall (style :: Symbol) (sym :: Symbol) b.
Integral b =>
b -> Named style sym -> Named style sym
sconcat :: NonEmpty (Named style sym) -> Named style sym
$csconcat :: forall (style :: Symbol) (sym :: Symbol).
NonEmpty (Named style sym) -> Named style sym
<> :: Named style sym -> Named style sym -> Named style sym
$c<> :: forall (style :: Symbol) (sym :: Symbol).
Named style sym -> Named style sym -> Named style sym
Semigroup)

-- | The NameStyle specifies how the name itself is styled.
--
--  * The 'UTF8' default style is orthogonal to a normal String or Text.
--
--  * The 'CaseInsensitive' style indicates that uppercase ASCII characters are
--    equivalent to their lowercase form.
--
--  * The Secure style is case sensitive, but does not reveal the full contents
--    unless the specific "secureName" accessor function is used.  This is useful
--    for storing secrets (e.g. passphrases, access tokens, etc.) that should not
--    be fully visible in log messages and other miscellaneous output.

type NameStyle = Symbol
type UTF8 = "UTF8" :: NameStyle
type CaseInsensitive = "CaseInsensitive" :: NameStyle
type Secure = "SECURE!" :: NameStyle

instance Hashable (Named style sym)


-- | Retrieve the @sym@ type parameter (the "what am I") of a Named as a text
-- value
nameOf :: KnownSymbol sym => Named style sym -> Proxy# sym -> String
nameOf :: forall (sym :: Symbol) (style :: Symbol).
KnownSymbol sym =>
Named style sym -> Proxy# sym -> String
nameOf Named style sym
_ = forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal'


nameProxy :: KnownSymbol sym => Named style sym -> Proxy sym
nameProxy :: forall (sym :: Symbol) (style :: Symbol).
KnownSymbol sym =>
Named style sym -> Proxy sym
nameProxy Named style sym
_ = forall {k} (t :: k). Proxy t
Proxy

styleProxy :: KnownSymbol style => Named style sym -> Proxy style
styleProxy :: forall (style :: Symbol) (sym :: Symbol).
KnownSymbol style =>
Named style sym -> Proxy style
styleProxy Named style sym
_ = forall {k} (t :: k). Proxy t
Proxy


instance {-# OVERLAPPABLE #-} IsString (Named style sym) where
  fromString :: String -> Named style sym
fromString = forall (style :: Symbol) (sym :: Symbol). Text -> Named style sym
Named forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString


class IsText a where fromText :: Text -> a
instance {-# OVERLAPPABLE #-} IsText (Named style sym) where
  fromText :: Text -> Named style sym
fromText = forall (style :: Symbol) (sym :: Symbol). Text -> Named style sym
Named


class ConvertName style origTy newTy where
  convertName :: Named style origTy -> Named style newTy
  convertName = forall a. IsText a => Text -> a
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named

class ConvertNameStyle inpStyle outStyle nameTy where
  convertStyle :: Named inpStyle nameTy -> Named outStyle nameTy
  convertStyle = forall a. IsText a => Text -> a
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named


-- | For an @"info"@ 'saytag' (and possibly others), a 'Name' doesn't include its
-- label.  Normally, it shows the label followed by the text itself.  The Sayable
-- defers to the Prettyprinting instance for actual representation.
instance NameText style => Sayable "info" (Named style nm) where
  sayable :: Named style nm -> Saying "info"
sayable = forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
PP.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (style :: Symbol) (nm :: Symbol).
NameText style =>
Named style nm -> Text
nameText
instance {-# OVERLAPPABLE #-} (PP.Pretty (Named style nm)
                              ) => Sayable tag (Named style nm)
 where sayable :: Named style nm -> Saying tag
sayable = forall (tag :: Symbol). Doc SayableAnn -> Saying tag
Saying forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
PP.pretty



----------------------------------------------------------------------

-- | The Name type is for the standard/most commonly used style which is
-- orthogonal to a normal String or Text.

type Name = Named UTF8

name :: Name sym -> Text
name :: forall (sym :: Symbol). Name sym -> Text
name = forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named


instance IsList (Name s) where
  type Item (Name s) = Item Text
  fromList :: [Item (Name s)] -> Name s
fromList = forall a. IsText a => Text -> a
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList
  toList :: Name s -> [Item (Name s)]
toList = forall l. IsList l => l -> [Item l]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol). Name sym -> Text
name

instance ConvertName UTF8 a a where convertName :: Named UTF8 a -> Named UTF8 a
convertName = forall a. a -> a
id
instance ConvertName UTF8 "component" "instance component"
instance ConvertName UTF8 "git.branch" "git.branch|ref"
instance ConvertName UTF8 "git.ref" "git.branch|ref"

instance KnownSymbol ty => PP.Pretty (Name ty) where
  pretty :: forall ann. Name ty -> Doc ann
pretty Name ty
nm = (forall a ann. Pretty a => a -> Doc ann
PP.pretty forall a b. (a -> b) -> a -> b
$ forall (sym :: Symbol) (style :: Symbol).
KnownSymbol sym =>
Named style sym -> Proxy# sym -> String
nameOf Name ty
nm forall {k} (a :: k). Proxy# a
proxy#) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
PP.squotes (forall a ann. Pretty a => a -> Doc ann
PP.pretty (forall (sym :: Symbol). Name sym -> Text
name Name ty
nm))


----------------------------------------------------------------------

data SomeName =
  forall (s :: Symbol) . KnownSymbol s => SomeName (Name s)

viewSomeName :: (forall (s :: Symbol) . KnownSymbol s => Name s -> r) -> SomeName -> r
viewSomeName :: forall r.
(forall (s :: Symbol). KnownSymbol s => Name s -> r)
-> SomeName -> r
viewSomeName forall (s :: Symbol). KnownSymbol s => Name s -> r
f (SomeName Name s
n) = forall (s :: Symbol). KnownSymbol s => Name s -> r
f Name s
n


data SomeNameStyle nameTy =
  forall (s :: Symbol)
  . (KnownSymbol s, NameText s)
  => SomeNameStyle (Named s nameTy)

viewSomeNameStyle :: (forall (s :: Symbol) . KnownSymbol s => Named s nameTy -> r)
                  -> SomeNameStyle nameTy -> r
viewSomeNameStyle :: forall (nameTy :: Symbol) r.
(forall (s :: Symbol). KnownSymbol s => Named s nameTy -> r)
-> SomeNameStyle nameTy -> r
viewSomeNameStyle forall (s :: Symbol). KnownSymbol s => Named s nameTy -> r
f (SomeNameStyle Named s nameTy
n) = forall (s :: Symbol). KnownSymbol s => Named s nameTy -> r
f Named s nameTy
n


----------------------------------------------------------------------

-- | Some objects have (contain) an associated name.  If they do, they can
-- declare the HasName constraint, and use myName to reconsistute the name from
-- the object.

class HasName x style nm | x -> style, x -> nm where
  myName :: x -> Named style nm


-- | A general class that can be used to extract the Text back out of a name.

class NameText style where
  nameText :: Named style nm -> Text
  nameText = forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named

instance NameText UTF8


----------------------------------------------------------------------

instance {-# OVERLAPPING #-} IsString (Named CaseInsensitive sym) where
  fromString :: String -> Named CaseInsensitive sym
fromString = forall (style :: Symbol) (sym :: Symbol). Text -> Named style sym
Named forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

instance {-# OVERLAPPING #-} IsText (Named CaseInsensitive sym) where
  fromText :: Text -> Named CaseInsensitive sym
fromText = forall (style :: Symbol) (sym :: Symbol). Text -> Named style sym
Named forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower

instance KnownSymbol ty => PP.Pretty (Named CaseInsensitive ty) where
  pretty :: forall ann. Named CaseInsensitive ty -> Doc ann
pretty Named CaseInsensitive ty
nm = (forall a ann. Pretty a => a -> Doc ann
PP.pretty forall a b. (a -> b) -> a -> b
$ forall (sym :: Symbol) (style :: Symbol).
KnownSymbol sym =>
Named style sym -> Proxy# sym -> String
nameOf Named CaseInsensitive ty
nm forall {k} (a :: k). Proxy# a
proxy#)
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
PP.surround (forall a ann. Pretty a => a -> Doc ann
PP.pretty (forall (sym :: Symbol). Named CaseInsensitive sym -> Text
caselessName Named CaseInsensitive ty
nm)) Doc ann
"«" Doc ann
"»"

instance NameText CaseInsensitive where
  nameText :: forall (sym :: Symbol). Named CaseInsensitive sym -> Text
nameText = forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named

caselessName :: Named CaseInsensitive sym -> Text
caselessName :: forall (sym :: Symbol). Named CaseInsensitive sym -> Text
caselessName = forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named


----------------------------------------------------------------------

-- | The SecureName is like Name, but its display form does not reveal
-- the full name.

type SecureName = Named Secure

-- | The secureName accessor is used to obtain the name field from a Secure
-- Named.  This is the normal accessor for a Secure Named and will occlude a
-- portion of the extracted name for protection.  For those specific cases where
-- the full Secure Named text is needed, the 'secureNameBypass' accessor should
-- be used instead.

secureName :: Named Secure sym -> Text
secureName :: forall (sym :: Symbol). Named Secure sym -> Text
secureName Named Secure sym
nm = if Text -> Int
T.length (forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named Named Secure sym
nm) forall a. Ord a => a -> a -> Bool
< Int
5
                then Int -> Text -> Text
T.replicate Int
8 Text
"#"
                else ((Int -> Text -> Text
T.take Int
2 forall a b. (a -> b) -> a -> b
$ forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named Named Secure sym
nm)
                      forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Text -> Int
T.length (forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named Named Secure sym
nm) forall a. Num a => a -> a -> a
- Int
4) Text
"#"
                      forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.reverse (Int -> Text -> Text
T.take Int
2 forall a b. (a -> b) -> a -> b
$ Text -> Text
T.reverse forall a b. (a -> b) -> a -> b
$ forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named Named Secure sym
nm))

-- | The secureNameBypass accessor is used to obtain the raw Text from a Secure
-- Named; this essentially bypasses the security protection and should only be
-- used in the limited cases when the raw form is absolutely needed.

secureNameBypass :: Named Secure sym -> Text
secureNameBypass :: forall (sym :: Symbol). Named Secure sym -> Text
secureNameBypass = forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named

-- instance NameText Secure sym   <-- explicitly not defined!

instance KnownSymbol ty => PP.Pretty (Named Secure ty) where
  pretty :: forall ann. Named Secure ty -> Doc ann
pretty Named Secure ty
nm = (forall a ann. Pretty a => a -> Doc ann
PP.pretty forall a b. (a -> b) -> a -> b
$ forall (sym :: Symbol) (style :: Symbol).
KnownSymbol sym =>
Named style sym -> Proxy# sym -> String
nameOf Named Secure ty
nm forall {k} (a :: k). Proxy# a
proxy#)
              forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
PP.squotes (forall a ann. Pretty a => a -> Doc ann
PP.pretty (forall (style :: Symbol) (sym :: Symbol). Named style sym -> Text
named Named Secure ty
nm))

-- Note that there should be no instance of ToJSON for a SecureName!


----------------------------------------------------------------------
-- | The ValidNames constraint can be used to specify the list of allowed names
-- for a parameterized name argument.


class ( KnownNat (AllowedNameType nty ntl)
      , DisallowedNameType nty ntl ntl
      )
  => ValidNames (nty :: Symbol) (ntl :: [Symbol]) where
  validName :: Proxy ntl -> Name nty -> Text


----------------------------------------------------------------------
-- Internal definitions to support the ValidNames constraint class
-- implementation.

instance ( KnownNat (AllowedNameType nty ntl)  -- n.b. if this fails, see Note-1
         , DisallowedNameType nty ntl ntl
         )
   => ValidNames nty ntl where
  validName :: Proxy ntl -> Name nty -> Text
validName Proxy ntl
_ = forall (sym :: Symbol). Name sym -> Text
name

type family AllowedNameType (nty :: Symbol) (ntl :: [Symbol]) :: Nat where
  AllowedNameType nty (nty ': ntl) = 0
  AllowedNameType nty (any ': ntl) = 1 + (AllowedNameType nty ntl)

-- * Note-1
--
-- Normally the DisallowedNameType will generate a useful TypeError if
-- a parameter uses a name not in the allowed names list.  For example:
--
-- > foo :: ValidNames n '[ "name1", "name 2" ] -> Name n -> Bool
-- > foo (Name @"name1" "indiana")  -- OK
-- > foo (Name @"last" "jones")  -- generates TypeError indicating
--                               -- "last" is not a member of the
--                               -- allowed list ["name1", "name 2"]
--
-- However, when parametric constraints are cascaded and the
-- parametric constraints don't align, the compilation complaint will
-- be that there's no KnownNat for the AllowedNameType instance
-- constraint on ValidNames above.  for example:
--
-- > bar :: ValidNames n '[ "name1", "stage" ]
-- > bar n = foo n
--
-- generates the KnownNat error.  Not sure of a better way to handle
-- this at the moment.

class DisallowedNameType (nty :: Symbol) (okntl :: [Symbol]) (ntl :: [Symbol])

instance TypeError ('Text "Name '" ':<>: 'ShowType nty
                    ':<>: 'Text "' not in allowed Names: " ':<>: 'ShowType ntl)
         => DisallowedNameType nty '[] ntl
instance DisallowedNameType nty (nty ': ntys) ntl
instance {-# OVERLAPPABLE #-} DisallowedNameType nty ntys ntl
         => DisallowedNameType nty (oty ': ntys) ntl