{-|
Module      : Prosidy.Types.Key
Description : Definitions and helpers for 'Key'.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE Safe #-}
module Prosidy.Types.Key
    ( -- * The 'Key' type.
      Key
      -- * Creating 'Key's and unwrapping them
    , makeKey
    , rawKey
    , unsafeMakeKey
      -- * Checking validity of raw text. 
    , isValidKeyHead
    , isValidKeyTail
      -- * Errors
    , KeyError(..)
    , InvalidCharacter(..)
    )
where

import           Prosidy.Internal.Classes

import           Data.Text                      ( Text )
import           Data.String                    ( IsString(..) )
import           Data.Foldable                  ( for_ )
import           Control.Monad                  ( unless )
import           Control.Exception              ( Exception(..)
                                                , throw
                                                )

import qualified Data.Char                     as Char
import qualified Data.Set                      as Set
import qualified Data.Text                     as Text

-- | A 'Key' is an identifier used in tags, properties, and setting names.
newtype Key = Key Text
  deriving stock (Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show, (forall x. Key -> Rep Key x)
-> (forall x. Rep Key x -> Key) -> Generic Key
forall x. Rep Key x -> Key
forall x. Key -> Rep Key x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Key x -> Key
$cfrom :: forall x. Key -> Rep Key x
Generic)
  deriving (Get Key
[Key] -> Put
Key -> Put
(Key -> Put) -> Get Key -> ([Key] -> Put) -> Binary Key
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Key] -> Put
$cputList :: [Key] -> Put
get :: Get Key
$cget :: Get Key
put :: Key -> Put
$cput :: Key -> Put
Binary, Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Int -> Key -> Int
Key -> Int
(Int -> Key -> Int) -> (Key -> Int) -> Hashable Key
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Key -> Int
$chash :: Key -> Int
hashWithSalt :: Int -> Key -> Int
$chashWithSalt :: Int -> Key -> Int
Hashable, Key -> ()
(Key -> ()) -> NFData Key
forall a. (a -> ()) -> NFData a
rnf :: Key -> ()
$crnf :: Key -> ()
NFData, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
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
min :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
$cp1Ord :: Eq Key
Ord, [Key] -> Encoding
[Key] -> Value
Key -> Encoding
Key -> Value
(Key -> Value)
-> (Key -> Encoding)
-> ([Key] -> Value)
-> ([Key] -> Encoding)
-> ToJSON Key
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Key] -> Encoding
$ctoEncodingList :: [Key] -> Encoding
toJSONList :: [Key] -> Value
$ctoJSONList :: [Key] -> Value
toEncoding :: Key -> Encoding
$ctoEncoding :: Key -> Encoding
toJSON :: Key -> Value
$ctoJSON :: Key -> Value
ToJSON, ToJSONKeyFunction [Key]
ToJSONKeyFunction Key
ToJSONKeyFunction Key -> ToJSONKeyFunction [Key] -> ToJSONKey Key
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [Key]
$ctoJSONKeyList :: ToJSONKeyFunction [Key]
toJSONKey :: ToJSONKeyFunction Key
$ctoJSONKey :: ToJSONKeyFunction Key
ToJSONKey) via Text

-- | 'Key' exposes an 'IsString' instance, but beware! Invalid strings will
-- throw a pure exception. 
instance IsString Key where
    fromString :: String -> Key
fromString = (KeyError -> Key) -> (Key -> Key) -> Either KeyError Key -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KeyError -> Key
forall a e. Exception e => e -> a
throw Key -> Key
forall a. a -> a
id (Either KeyError Key -> Key)
-> (String -> Either KeyError Key) -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either KeyError Key
makeKey (Text -> Either KeyError Key)
-> (String -> Text) -> String -> Either KeyError Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

instance FromJSON Key where
    parseJSON :: Value -> Parser Key
parseJSON json :: Value
json = do
        Text
text <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
json
        (KeyError -> Parser Key)
-> (Key -> Parser Key) -> Either KeyError Key -> Parser Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Key
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Key)
-> (KeyError -> String) -> KeyError -> Parser Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyError -> String
forall e. Exception e => e -> String
displayException) Key -> Parser Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either KeyError Key -> Parser Key)
-> Either KeyError Key -> Parser Key
forall a b. (a -> b) -> a -> b
$ Text -> Either KeyError Key
makeKey Text
text

instance Pretty Key where
    pretty :: Key -> Doc ann
pretty = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> (Key -> Text) -> Key -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
rawKey

-- | Create a new 'Key', checking its validity.
makeKey :: Text -> Either KeyError Key
makeKey :: Text -> Either KeyError Key
makeKey rawText :: Text
rawText = case Text -> String
Text.unpack Text
rawText of
    [] -> KeyError -> Either KeyError Key
forall a b. a -> Either a b
Left KeyError
EmptyKeyError
    keyHead :: Char
keyHead : keyTail :: String
keyTail
        | Char -> Bool
isValidKeyHead Char
keyHead -> do
            [(Word, Char)]
-> ((Word, Char) -> Either KeyError ()) -> Either KeyError ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Word] -> String -> [(Word, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1 ..] String
keyTail) (((Word, Char) -> Either KeyError ()) -> Either KeyError ())
-> ((Word, Char) -> Either KeyError ()) -> Either KeyError ()
forall a b. (a -> b) -> a -> b
$ \(ix :: Word
ix, ch :: Char
ch) ->
                Bool -> Either KeyError () -> Either KeyError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char -> Bool
isValidKeyTail Char
ch)
                    (Either KeyError () -> Either KeyError ())
-> Either KeyError () -> Either KeyError ()
forall a b. (a -> b) -> a -> b
$ KeyError -> Either KeyError ()
forall a b. a -> Either a b
Left
                    (KeyError -> Either KeyError ())
-> (InvalidCharacter -> KeyError)
-> InvalidCharacter
-> Either KeyError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvalidCharacter -> KeyError
InvalidCharacterError
                    (InvalidCharacter -> Either KeyError ())
-> InvalidCharacter -> Either KeyError ()
forall a b. (a -> b) -> a -> b
$ Text -> Word -> Char -> InvalidCharacter
InvalidCharacter Text
rawText Word
ix Char
ch
            Key -> Either KeyError Key
forall a b. b -> Either a b
Right (Key -> Either KeyError Key) -> Key -> Either KeyError Key
forall a b. (a -> b) -> a -> b
$ Text -> Key
Key Text
rawText
        | Bool
otherwise -> KeyError -> Either KeyError Key
forall a b. a -> Either a b
Left (KeyError -> Either KeyError Key)
-> (InvalidCharacter -> KeyError)
-> InvalidCharacter
-> Either KeyError Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvalidCharacter -> KeyError
InvalidCharacterError (InvalidCharacter -> Either KeyError Key)
-> InvalidCharacter -> Either KeyError Key
forall a b. (a -> b) -> a -> b
$ Text -> Word -> Char -> InvalidCharacter
InvalidCharacter
            Text
rawText
            0
            Char
keyHead

-- | Create a new 'Key' /without/ performing any checks.
unsafeMakeKey :: Text -> Key
unsafeMakeKey :: Text -> Key
unsafeMakeKey = Text -> Key
Key
{-# INLINE unsafeMakeKey #-}

-- | Convert a 'Key' into its 'Text' representation.
rawKey :: Key -> Text
rawKey :: Key -> Text
rawKey (Key key :: Text
key) = Text
key

-- | Check if a character is suitable for use as the first character in a 
-- 'Key'.
isValidKeyHead :: Char -> Bool
isValidKeyHead :: Char -> Bool
isValidKeyHead = Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Bool
Char.isAlphaNum (Char -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_')

-- | Check if a character is suitable for use as any character except the
-- first character in a 'Key'.
isValidKeyTail :: Char -> Bool
isValidKeyTail :: Char -> Bool
isValidKeyTail = Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
invalid
  where
    invalid :: Char -> Bool
invalid  = Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Bool
Char.isSpace (Char -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Char
reserved)
    reserved :: Set Char
reserved = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList "\\#{}[]:=,"

-- | Errors returned when creating invalid keys.
data KeyError =
    InvalidCharacterError InvalidCharacter
    -- ^ A character provided as a 'Key'\'s name was invalid.
  | EmptyKeyError
    -- ^ A string of length 0 was provided as a 'Key'\'s name.
  deriving (Int -> KeyError -> ShowS
[KeyError] -> ShowS
KeyError -> String
(Int -> KeyError -> ShowS)
-> (KeyError -> String) -> ([KeyError] -> ShowS) -> Show KeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyError] -> ShowS
$cshowList :: [KeyError] -> ShowS
show :: KeyError -> String
$cshow :: KeyError -> String
showsPrec :: Int -> KeyError -> ShowS
$cshowsPrec :: Int -> KeyError -> ShowS
Show, KeyError -> KeyError -> Bool
(KeyError -> KeyError -> Bool)
-> (KeyError -> KeyError -> Bool) -> Eq KeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyError -> KeyError -> Bool
$c/= :: KeyError -> KeyError -> Bool
== :: KeyError -> KeyError -> Bool
$c== :: KeyError -> KeyError -> Bool
Eq)

-- | Details for errors thrown when creating 'Key's with one or more invalid
-- characters.
data InvalidCharacter = InvalidCharacter
    { -- | The full string provided as the 'Key's name.
      InvalidCharacter -> Text
invalidCharacterText :: Text
      -- | The position of the invalid character.
    , InvalidCharacter -> Word
invalidCharacterPosition :: Word
      -- | The exact character that was invalid.
    , InvalidCharacter -> Char
invalidCharacterCharacter :: Char
    }
  deriving (Int -> InvalidCharacter -> ShowS
[InvalidCharacter] -> ShowS
InvalidCharacter -> String
(Int -> InvalidCharacter -> ShowS)
-> (InvalidCharacter -> String)
-> ([InvalidCharacter] -> ShowS)
-> Show InvalidCharacter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidCharacter] -> ShowS
$cshowList :: [InvalidCharacter] -> ShowS
show :: InvalidCharacter -> String
$cshow :: InvalidCharacter -> String
showsPrec :: Int -> InvalidCharacter -> ShowS
$cshowsPrec :: Int -> InvalidCharacter -> ShowS
Show, InvalidCharacter -> InvalidCharacter -> Bool
(InvalidCharacter -> InvalidCharacter -> Bool)
-> (InvalidCharacter -> InvalidCharacter -> Bool)
-> Eq InvalidCharacter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidCharacter -> InvalidCharacter -> Bool
$c/= :: InvalidCharacter -> InvalidCharacter -> Bool
== :: InvalidCharacter -> InvalidCharacter -> Bool
$c== :: InvalidCharacter -> InvalidCharacter -> Bool
Eq)

instance Exception KeyError where
    displayException :: KeyError -> String
displayException EmptyKeyError =
        "Cannot create a Key with a length of zero."
    displayException (InvalidCharacterError (InvalidCharacter text :: Text
text nth :: Word
nth ch :: Char
ch)) =
        [String] -> String
unwords
            [ "Cannot create a Key named " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
text String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ":"
            , "the character"
            , Char -> String
forall a. Show a => a -> String
show Char
ch
            , "at index"
            , Word -> String
forall a. Show a => a -> String
show Word
nth
            , "is not allowed."
            ]