{-# LANGUAGE CPP #-}

module Text.Format.ArgKey ( ArgKey (..), topKey, popKey ) where

import           Control.Arrow
import           Data.Char         (isDigit)
import qualified Data.List         as L
#if MIN_VERSION_base(4, 11, 0)
import           Data.Semigroup
#endif

import           Text.Format.Error


{-| A data type indicates key of format argument

==== The key syntax

  @
  key -> [(int | chars) {"!" (int | chars)}]
  @

  Since the "!" is used to seprate keys, if you need to include a "!" in a
  named key, it can be escaped by doubling "!!".

  Note: See 'Format' to learn more about syntax description language

  Examples

    >>> read "0" :: ArgKey
    >>> read "country" :: ArgKey
    >>> read "coun!!try" :: ArgKey
    >>> read "country!name" :: ArgKey
    >>> read "country!cities!10!name" :: ArgKey
-}
data ArgKey = Index Int           -- ^ Refers to a top-level positional
                                  -- argument or an element in  an list-like
                                  -- data type.
            | Name String         -- ^ Refers to a top-level named argument or
                                  -- a field of a record data type.
            | Nest ArgKey ArgKey  -- ^ For @Nest k1 k2@, k1 refers to a
                                  -- top-level argument or an attribute
                                  -- (element or field) of a data type,
                                  -- k2 refers an attribute of the data
                                  -- referenced by k1.
            deriving (ArgKey -> ArgKey -> Bool
(ArgKey -> ArgKey -> Bool)
-> (ArgKey -> ArgKey -> Bool) -> Eq ArgKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArgKey -> ArgKey -> Bool
== :: ArgKey -> ArgKey -> Bool
$c/= :: ArgKey -> ArgKey -> Bool
/= :: ArgKey -> ArgKey -> Bool
Eq, Eq ArgKey
Eq ArgKey =>
(ArgKey -> ArgKey -> Ordering)
-> (ArgKey -> ArgKey -> Bool)
-> (ArgKey -> ArgKey -> Bool)
-> (ArgKey -> ArgKey -> Bool)
-> (ArgKey -> ArgKey -> Bool)
-> (ArgKey -> ArgKey -> ArgKey)
-> (ArgKey -> ArgKey -> ArgKey)
-> Ord ArgKey
ArgKey -> ArgKey -> Bool
ArgKey -> ArgKey -> Ordering
ArgKey -> ArgKey -> ArgKey
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
$ccompare :: ArgKey -> ArgKey -> Ordering
compare :: ArgKey -> ArgKey -> Ordering
$c< :: ArgKey -> ArgKey -> Bool
< :: ArgKey -> ArgKey -> Bool
$c<= :: ArgKey -> ArgKey -> Bool
<= :: ArgKey -> ArgKey -> Bool
$c> :: ArgKey -> ArgKey -> Bool
> :: ArgKey -> ArgKey -> Bool
$c>= :: ArgKey -> ArgKey -> Bool
>= :: ArgKey -> ArgKey -> Bool
$cmax :: ArgKey -> ArgKey -> ArgKey
max :: ArgKey -> ArgKey -> ArgKey
$cmin :: ArgKey -> ArgKey -> ArgKey
min :: ArgKey -> ArgKey -> ArgKey
Ord)

#if MIN_VERSION_base(4, 11, 0)
instance Semigroup ArgKey where
  <> :: ArgKey -> ArgKey -> ArgKey
(<>) = ArgKey -> ArgKey -> ArgKey
associate
#endif

instance Monoid ArgKey where
  -- | @Index -1@ is used as an empty key
  mempty :: ArgKey
mempty = Int -> ArgKey
Index (-Int
1)
#if !MIN_VERSION_base(4, 11, 0)
  mappend = associate
#endif

instance Read ArgKey where
  readsPrec :: Int -> ReadS ArgKey
readsPrec Int
_ String
"" = [ (ArgKey
forall a. Monoid a => a
mempty, String
"") ]
  readsPrec Int
_ String
cs = [ String -> (ArgKey, String)
parse String
cs ]
    where
      parse :: String -> (ArgKey, String)
      parse :: String -> (ArgKey, String)
parse String
cs =
        case String -> (String, String)
break String
cs of
          (String
"", String
cs1)  -> (ArgKey
forall a. HasCallStack => a
undefined, String
cs1)
          (String
_, String
"!")   -> (ArgKey
forall a. HasCallStack => a
undefined, String
"!")
          (String
cs1, String
"")  -> (String -> ArgKey
parse1 String
cs1, String
"")
          (String
cs1, String
cs2) -> (ArgKey -> ArgKey) -> (ArgKey, String) -> (ArgKey, String)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (ArgKey -> ArgKey -> ArgKey
forall a. Monoid a => a -> a -> a
mappend (ArgKey -> ArgKey -> ArgKey) -> ArgKey -> ArgKey -> ArgKey
forall a b. (a -> b) -> a -> b
$ String -> ArgKey
parse1 String
cs1) (String -> (ArgKey, String)
parse String
cs2)

      parse1 :: String -> ArgKey
      parse1 :: String -> ArgKey
parse1 String
cs = if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
cs then Int -> ArgKey
Index (String -> Int
forall a. Read a => String -> a
read String
cs) else String -> ArgKey
Name String
cs

      break :: String -> (String, String)
      break :: String -> (String, String)
break String
cs =
        case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!') String
cs of
          (String
cs1, String
"")              -> (String
cs1, String
"")
          (String
cs1, String
"!")             -> (String
cs1, String
"!")
          (String
cs1, Char
'!' : Char
'!' : String
cs2) -> (String -> String) -> (String, String) -> (String, String)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((String
cs1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> (String, String)
break String
cs2)
          (String
cs1, Char
'!' : String
cs2)       -> (String
cs1, String
cs2)

instance Show ArgKey where
  show :: ArgKey -> String
show k :: ArgKey
k@(Index Int
i) = if ArgKey
forall a. Monoid a => a
mempty ArgKey -> ArgKey -> Bool
forall a. Eq a => a -> a -> Bool
== ArgKey
k then String
"" else Int -> String
forall a. Show a => a -> String
show Int
i
  show (Name String
s)    = String -> String
escape String
s
    where
      escape :: String -> String
      escape :: String -> String
escape String
""         = String
""
      escape (Char
'!' : String
cs) = String
"!!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
cs
      escape (Char
c : String
cs)   = (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs)
  show (Nest ArgKey
k1 ArgKey
k2)  = ArgKey -> String
forall a. Show a => a -> String
show ArgKey
k1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ArgKey -> String
forall a. Show a => a -> String
show ArgKey
k2


associate :: ArgKey -> ArgKey -> ArgKey
associate :: ArgKey -> ArgKey -> ArgKey
associate ArgKey
k (Index (-1))    = ArgKey
k
associate (Index (-1)) ArgKey
k    = ArgKey
k
associate (Nest ArgKey
k11 ArgKey
k12) ArgKey
k2 = ArgKey -> ArgKey -> ArgKey
associate ArgKey
k11 (ArgKey -> ArgKey) -> ArgKey -> ArgKey
forall a b. (a -> b) -> a -> b
$ ArgKey -> ArgKey -> ArgKey
associate ArgKey
k12 ArgKey
k2
associate ArgKey
k1 ArgKey
k2             = ArgKey -> ArgKey -> ArgKey
Nest ArgKey
k1 ArgKey
k2


{-| Extract the topmost indexed or named key from a key

>>> topKey (read "k1!k2!k3") == Name "k1"
True
>>> topKey (read "name") == Name "name"
True
>>> topKey (read "123") == Index 123
True
>>> topKey mempty
*** Exception: vformat: empty arg key
-}
topKey :: ArgKey -> ArgKey
topKey :: ArgKey -> ArgKey
topKey (Nest k :: ArgKey
k@(Nest ArgKey
_ ArgKey
_) ArgKey
_) = ArgKey -> ArgKey
topKey ArgKey
k
topKey (Nest ArgKey
k ArgKey
_) = ArgKey
k
topKey ArgKey
k = if ArgKey
k ArgKey -> ArgKey -> Bool
forall a. Eq a => a -> a -> Bool
== ArgKey
forall a. Monoid a => a
mempty then String -> ArgKey
forall a. String -> a
vferror String
"empty arg key"
                          else ArgKey
k

{-| Remove the topmost indexed or named key from a key

>>> popKey (read "k1!k2!k3") == read "k2!k3"
True
>>> popKey (read "name") == mempty
True
>>> popKey (read "123") == mempty
True
>>> popKey mempty
*** Exception: vformat: empty arg key
-}
popKey :: ArgKey -> ArgKey
popKey :: ArgKey -> ArgKey
popKey (Nest k1 :: ArgKey
k1@(Nest ArgKey
_ ArgKey
_) ArgKey
k2) = ArgKey -> ArgKey -> ArgKey
forall a. Monoid a => a -> a -> a
mappend (ArgKey -> ArgKey
popKey ArgKey
k1) ArgKey
k2
popKey (Nest ArgKey
_ ArgKey
k) = ArgKey
k
popKey ArgKey
k = if ArgKey
k ArgKey -> ArgKey -> Bool
forall a. Eq a => a -> a -> Bool
== ArgKey
forall a. Monoid a => a
mempty then String -> ArgKey
forall a. String -> a
vferror String
"empty arg key"
                          else ArgKey
forall a. Monoid a => a
mempty