{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving         #-}

module Data.KeyStore.Types.NameAndSafeguard
    ( Name
    , name
    , _name
    , Safeguard
    , safeguard
    , safeguardKeys
    , isWildSafeguard
    , printSafeguard
    , parseSafeguard
    ) where

import           Data.KeyStore.Types.E
import           Data.Char
import qualified Data.Set                       as Set
import           Data.String
import qualified Control.Exception              as X

newtype Name
    = Name            { Name -> String
_Name            :: String       }
    deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq,Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
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 :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord,String -> Name
(String -> Name) -> IsString Name
forall a. (String -> a) -> IsString a
fromString :: String -> Name
$cfromString :: String -> Name
IsString,ReadPrec [Name]
ReadPrec Name
Int -> ReadS Name
ReadS [Name]
(Int -> ReadS Name)
-> ReadS [Name] -> ReadPrec Name -> ReadPrec [Name] -> Read Name
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Name]
$creadListPrec :: ReadPrec [Name]
readPrec :: ReadPrec Name
$creadPrec :: ReadPrec Name
readList :: ReadS [Name]
$creadList :: ReadS [Name]
readsPrec :: Int -> ReadS Name
$creadsPrec :: Int -> ReadS Name
Read,Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show)


name :: String -> E Name
name :: String -> E Name
name String
s =
    case (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
is_nm_char String
s of
        Bool
True  -> Name -> E Name
forall a b. b -> Either a b
Right (Name -> E Name) -> Name -> E Name
forall a b. (a -> b) -> a -> b
$ String -> Name
Name String
s
        Bool
False -> Reason -> E Name
forall a b. a -> Either a b
Left  (Reason -> E Name) -> Reason -> E Name
forall a b. (a -> b) -> a -> b
$ String -> Reason
forall a. Error a => String -> a
strMsg String
"bad name syntax"

_name :: Name -> String
_name :: Name -> String
_name = Name -> String
_Name


newtype Safeguard
    = Safeguard { Safeguard -> Set Name
_Safeguard :: Set.Set Name }
    deriving (Safeguard -> Safeguard -> Bool
(Safeguard -> Safeguard -> Bool)
-> (Safeguard -> Safeguard -> Bool) -> Eq Safeguard
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Safeguard -> Safeguard -> Bool
$c/= :: Safeguard -> Safeguard -> Bool
== :: Safeguard -> Safeguard -> Bool
$c== :: Safeguard -> Safeguard -> Bool
Eq,Eq Safeguard
Eq Safeguard
-> (Safeguard -> Safeguard -> Ordering)
-> (Safeguard -> Safeguard -> Bool)
-> (Safeguard -> Safeguard -> Bool)
-> (Safeguard -> Safeguard -> Bool)
-> (Safeguard -> Safeguard -> Bool)
-> (Safeguard -> Safeguard -> Safeguard)
-> (Safeguard -> Safeguard -> Safeguard)
-> Ord Safeguard
Safeguard -> Safeguard -> Bool
Safeguard -> Safeguard -> Ordering
Safeguard -> Safeguard -> Safeguard
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 :: Safeguard -> Safeguard -> Safeguard
$cmin :: Safeguard -> Safeguard -> Safeguard
max :: Safeguard -> Safeguard -> Safeguard
$cmax :: Safeguard -> Safeguard -> Safeguard
>= :: Safeguard -> Safeguard -> Bool
$c>= :: Safeguard -> Safeguard -> Bool
> :: Safeguard -> Safeguard -> Bool
$c> :: Safeguard -> Safeguard -> Bool
<= :: Safeguard -> Safeguard -> Bool
$c<= :: Safeguard -> Safeguard -> Bool
< :: Safeguard -> Safeguard -> Bool
$c< :: Safeguard -> Safeguard -> Bool
compare :: Safeguard -> Safeguard -> Ordering
$ccompare :: Safeguard -> Safeguard -> Ordering
$cp1Ord :: Eq Safeguard
Ord,Int -> Safeguard -> ShowS
[Safeguard] -> ShowS
Safeguard -> String
(Int -> Safeguard -> ShowS)
-> (Safeguard -> String)
-> ([Safeguard] -> ShowS)
-> Show Safeguard
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Safeguard] -> ShowS
$cshowList :: [Safeguard] -> ShowS
show :: Safeguard -> String
$cshow :: Safeguard -> String
showsPrec :: Int -> Safeguard -> ShowS
$cshowsPrec :: Int -> Safeguard -> ShowS
Show)

instance IsString Safeguard where
    fromString :: String -> Safeguard
fromString String
s =
        case String -> E Safeguard
parseSafeguard String
s of
          Left Reason
err -> Reason -> Safeguard
forall a e. Exception e => e -> a
X.throw Reason
err
          Right Safeguard
sg -> Safeguard
sg

safeguard :: [Name] -> Safeguard
safeguard :: [Name] -> Safeguard
safeguard = Set Name -> Safeguard
Safeguard (Set Name -> Safeguard)
-> ([Name] -> Set Name) -> [Name] -> Safeguard
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList

safeguardKeys :: Safeguard -> [Name]
safeguardKeys :: Safeguard -> [Name]
safeguardKeys = Set Name -> [Name]
forall a. Set a -> [a]
Set.elems (Set Name -> [Name])
-> (Safeguard -> Set Name) -> Safeguard -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Safeguard -> Set Name
_Safeguard

isWildSafeguard :: Safeguard -> Bool
isWildSafeguard :: Safeguard -> Bool
isWildSafeguard = [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> (Safeguard -> [Name]) -> Safeguard -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Safeguard -> [Name]
safeguardKeys

printSafeguard :: Safeguard -> String
printSafeguard :: Safeguard -> String
printSafeguard (Safeguard Set Name
st) =
    case Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
st of
      Bool
True  -> String
"*"
      Bool
False -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
tr ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
_name ([Name] -> [String]) -> [Name] -> [String]
forall a b. (a -> b) -> a -> b
$ Set Name -> [Name]
forall a. Set a -> [a]
Set.elems Set Name
st
  where
    tr :: Char -> Char
tr Char
' ' = Char
','
    tr Char
c   = Char
c

parseSafeguard :: String -> E Safeguard
parseSafeguard :: String -> E Safeguard
parseSafeguard String
s =
    case String
s of
      String
"*"             -> Safeguard -> E Safeguard
forall a b. b -> Either a b
Right (Safeguard -> E Safeguard) -> Safeguard -> E Safeguard
forall a b. (a -> b) -> a -> b
$ [Name] -> Safeguard
safeguard []
      String
_   | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
chk String
s -> Safeguard -> E Safeguard
chk'  (Safeguard -> E Safeguard) -> Safeguard -> E Safeguard
forall a b. (a -> b) -> a -> b
$ [Name] -> Safeguard
safeguard ([Name] -> Safeguard) -> [Name] -> Safeguard
forall a b. (a -> b) -> a -> b
$ (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
Name ([String] -> [Name]) -> [String] -> [Name]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
tr String
s
          | Bool
otherwise -> E Safeguard
forall b. Either Reason b
oops
  where
    chk :: Char -> Bool
chk  Char
c  = Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',' Bool -> Bool -> Bool
|| Char -> Bool
is_nm_char Char
c

    chk' :: Safeguard -> E Safeguard
chk' Safeguard
sg =
        case Safeguard -> Bool
isWildSafeguard Safeguard
sg of
          Bool
True  -> E Safeguard
forall b. Either Reason b
oops
          Bool
False -> Safeguard -> E Safeguard
forall a b. b -> Either a b
Right Safeguard
sg

    tr :: Char -> Char
tr Char
','  = Char
' '
    tr Char
c    = Char
c

    oops :: Either Reason b
oops    = Reason -> Either Reason b
forall a b. a -> Either a b
Left (Reason -> Either Reason b) -> Reason -> Either Reason b
forall a b. (a -> b) -> a -> b
$ String -> Reason
forall a. Error a => String -> a
strMsg String
"bad safeguard syntax"

is_nm_char :: Char -> Bool
is_nm_char :: Char -> Bool
is_nm_char Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Char
sg_sym_chs

sg_sym_chs :: Set.Set Char
sg_sym_chs :: Set Char
sg_sym_chs = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList String
".-_:'=#$%"