{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Panfiguration.FromParam (
    FromParam(..)
    , readFromParam
    -- * Wrappers
    , Secret(..)
    , Collect(..)
    ) where

import Control.Applicative
import Data.ByteString.Char8 as BC (ByteString, pack)
import Data.Char
import Data.Functor.Identity
import Data.Monoid
import Data.Typeable
import Network.Socket (PortNumber)
import Numeric.Natural
import Text.Read (readMaybe)
import qualified Data.Text as Text

-- | A newtype wrapper to distinguish confidential values.
-- 'show' and error messages from 'fromParam' mask its contents.
newtype Secret a = Secret { forall a. Secret a -> a
unSecret :: a } deriving (Secret a -> Secret a -> Bool
forall a. Eq a => Secret a -> Secret a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Secret a -> Secret a -> Bool
$c/= :: forall a. Eq a => Secret a -> Secret a -> Bool
== :: Secret a -> Secret a -> Bool
$c== :: forall a. Eq a => Secret a -> Secret a -> Bool
Eq, Secret a -> Secret a -> Bool
Secret a -> Secret a -> Ordering
Secret a -> Secret a -> Secret a
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 {a}. Ord a => Eq (Secret a)
forall a. Ord a => Secret a -> Secret a -> Bool
forall a. Ord a => Secret a -> Secret a -> Ordering
forall a. Ord a => Secret a -> Secret a -> Secret a
min :: Secret a -> Secret a -> Secret a
$cmin :: forall a. Ord a => Secret a -> Secret a -> Secret a
max :: Secret a -> Secret a -> Secret a
$cmax :: forall a. Ord a => Secret a -> Secret a -> Secret a
>= :: Secret a -> Secret a -> Bool
$c>= :: forall a. Ord a => Secret a -> Secret a -> Bool
> :: Secret a -> Secret a -> Bool
$c> :: forall a. Ord a => Secret a -> Secret a -> Bool
<= :: Secret a -> Secret a -> Bool
$c<= :: forall a. Ord a => Secret a -> Secret a -> Bool
< :: Secret a -> Secret a -> Bool
$c< :: forall a. Ord a => Secret a -> Secret a -> Bool
compare :: Secret a -> Secret a -> Ordering
$ccompare :: forall a. Ord a => Secret a -> Secret a -> Ordering
Ord)

instance Show a => Show (Secret a) where
    show :: Secret a -> String
show = (Char
'*' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Secret a -> a
unSecret

class FromParam a where
    -- | Parse a parameter
    fromParam :: String -> Either String a
    default fromParam :: (Typeable a, Read a) => String -> Either String a
    fromParam = forall a. (Typeable a, Read a) => String -> Either String a
readFromParam

    fromParamList :: String -> Either String [a]
    fromParamList String
_ = forall a b. a -> Either a b
Left String
"No implementation for fromParamList"

    -- | Merge two parameters. The 'Ordering' indicates which side of the arguments is used.
    mergeParams :: a -> a -> (Ordering, a)
    mergeParams a
a a
_ = (Ordering
LT, a
a)

-- | A reasonable default implementation for 'fromParam' via 'Read'
readFromParam :: forall a. (Typeable a, Read a) => String -> Either String a
readFromParam :: forall a. (Typeable a, Read a) => String -> Either String a
readFromParam String
str = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left String
err) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> Maybe a
readMaybe String
str
    where
        err :: String
err = [String] -> String
unwords [String
"failed to parse", String
str, String
"as", forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))]

instance (Typeable a, FromParam a) => FromParam (Secret a) where
    fromParam :: String -> Either String (Secret a)
fromParam String
str = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall {b}. Either String b
err) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Secret a
Secret) forall a b. (a -> b) -> a -> b
$ forall a. FromParam a => String -> Either String a
fromParam String
str where
        err :: Either String b
err = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"failed to parse", Char
'*' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String
str, String
"as", forall a. Show a => a -> String
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))]

instance FromParam Bool where
    fromParam :: String -> Either String Bool
fromParam String
str = case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
str of
        String
"false" -> forall a b. b -> Either a b
Right Bool
False
        String
"true" -> forall a b. b -> Either a b
Right Bool
True
        String
_ -> forall a b. a -> Either a b
Left String
"Expected true or false"

instance FromParam Char where
    fromParam :: String -> Either String Char
fromParam [Char
c] = forall a b. b -> Either a b
Right Char
c
    fromParam String
_ = forall a b. a -> Either a b
Left String
"Got more than one character"
    fromParamList :: String -> Either String String
fromParamList = forall a b. b -> Either a b
Right

instance FromParam a => FromParam [a] where
    fromParam :: String -> Either String [a]
fromParam = forall a. FromParam a => String -> Either String [a]
fromParamList

instance FromParam () where
    fromParam :: String -> Either String ()
fromParam String
_ = forall a b. b -> Either a b
Right ()
deriving instance FromParam a => FromParam (Identity a)
deriving instance FromParam a => FromParam (Const a b)
instance FromParam Int
instance FromParam Float
instance FromParam Double
instance FromParam Integer
instance FromParam Natural
instance FromParam PortNumber
instance FromParam Text.Text where
    fromParam :: String -> Either String Text
fromParam = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

instance FromParam ByteString where
    fromParam :: String -> Either String ByteString
fromParam String
str
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall a. Ord a => a -> a -> Bool
<Int
128) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) String
str = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
str
        | Bool
otherwise = forall a b. a -> Either a b
Left String
"expected ByteString, but found a non-ASCII character"

instance FromParam a => FromParam (Maybe a) where
    fromParam :: String -> Either String (Maybe a)
fromParam String
str = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromParam a => String -> Either String a
fromParam String
str

instance FromParam Any where
    fromParam :: String -> Either String Any
fromParam = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromParam a => String -> Either String a
fromParam
    mergeParams :: Any -> Any -> (Ordering, Any)
mergeParams (Any Bool
False) Any
a = (Ordering
GT, Any
a)
    mergeParams (Any Bool
True) Any
_ = (Ordering
LT, Bool -> Any
Any Bool
True)

instance FromParam All where
    fromParam :: String -> Either String All
fromParam = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromParam a => String -> Either String a
fromParam
    mergeParams :: All -> All -> (Ordering, All)
mergeParams (All Bool
False) All
_ = (Ordering
LT, Bool -> All
All Bool
False)
    mergeParams (All Bool
True) All
a = (Ordering
GT, All
a)

-- | Collect all the specified parameters instead of overriding
newtype Collect a = Collect { forall a. Collect a -> [a]
unCollect :: [a] } deriving (Collect a -> Collect a -> Bool
forall a. Eq a => Collect a -> Collect a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Collect a -> Collect a -> Bool
$c/= :: forall a. Eq a => Collect a -> Collect a -> Bool
== :: Collect a -> Collect a -> Bool
$c== :: forall a. Eq a => Collect a -> Collect a -> Bool
Eq, Collect a -> Collect a -> Bool
Collect a -> Collect a -> Ordering
Collect a -> Collect a -> Collect a
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 {a}. Ord a => Eq (Collect a)
forall a. Ord a => Collect a -> Collect a -> Bool
forall a. Ord a => Collect a -> Collect a -> Ordering
forall a. Ord a => Collect a -> Collect a -> Collect a
min :: Collect a -> Collect a -> Collect a
$cmin :: forall a. Ord a => Collect a -> Collect a -> Collect a
max :: Collect a -> Collect a -> Collect a
$cmax :: forall a. Ord a => Collect a -> Collect a -> Collect a
>= :: Collect a -> Collect a -> Bool
$c>= :: forall a. Ord a => Collect a -> Collect a -> Bool
> :: Collect a -> Collect a -> Bool
$c> :: forall a. Ord a => Collect a -> Collect a -> Bool
<= :: Collect a -> Collect a -> Bool
$c<= :: forall a. Ord a => Collect a -> Collect a -> Bool
< :: Collect a -> Collect a -> Bool
$c< :: forall a. Ord a => Collect a -> Collect a -> Bool
compare :: Collect a -> Collect a -> Ordering
$ccompare :: forall a. Ord a => Collect a -> Collect a -> Ordering
Ord, Int -> Collect a -> ShowS
forall a. Show a => Int -> Collect a -> ShowS
forall a. Show a => [Collect a] -> ShowS
forall a. Show a => Collect a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Collect a] -> ShowS
$cshowList :: forall a. Show a => [Collect a] -> ShowS
show :: Collect a -> String
$cshow :: forall a. Show a => Collect a -> String
showsPrec :: Int -> Collect a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Collect a -> ShowS
Show, NonEmpty (Collect a) -> Collect a
Collect a -> Collect a -> Collect a
forall b. Integral b => b -> Collect a -> Collect a
forall a. NonEmpty (Collect a) -> Collect a
forall a. Collect a -> Collect a -> Collect a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Collect a -> Collect a
stimes :: forall b. Integral b => b -> Collect a -> Collect a
$cstimes :: forall a b. Integral b => b -> Collect a -> Collect a
sconcat :: NonEmpty (Collect a) -> Collect a
$csconcat :: forall a. NonEmpty (Collect a) -> Collect a
<> :: Collect a -> Collect a -> Collect a
$c<> :: forall a. Collect a -> Collect a -> Collect a
Semigroup, Collect a
[Collect a] -> Collect a
Collect a -> Collect a -> Collect a
forall a. Semigroup (Collect a)
forall a. Collect a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Collect a] -> Collect a
forall a. Collect a -> Collect a -> Collect a
mconcat :: [Collect a] -> Collect a
$cmconcat :: forall a. [Collect a] -> Collect a
mappend :: Collect a -> Collect a -> Collect a
$cmappend :: forall a. Collect a -> Collect a -> Collect a
mempty :: Collect a
$cmempty :: forall a. Collect a
Monoid)

instance FromParam a => FromParam (Collect a) where
    fromParam :: String -> Either String (Collect a)
fromParam = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> Collect a
Collect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromParam a => String -> Either String a
fromParam
    mergeParams :: Collect a -> Collect a -> (Ordering, Collect a)
mergeParams Collect a
a (Collect []) = (Ordering
LT, Collect a
a)
    mergeParams (Collect []) Collect a
b = (Ordering
GT, Collect a
b)
    mergeParams (Collect [a]
a) (Collect [a]
b) = (Ordering
EQ, forall a. [a] -> Collect a
Collect forall a b. (a -> b) -> a -> b
$ [a]
a forall a. Semigroup a => a -> a -> a
<> [a]
b)