{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module: Data.Env.TypeParser
-- Description: Type class that provides parsers for types.
--
-- This module provides a type class 'TypeParser' that provides parsers for
-- different types. The parsers are used to parse environment variables from
-- their string representation.
module Data.Env.TypeParser (
  TypeParser (..),
) where

import           Data.Int (Int8, Int16, Int32, Int64)
import           Data.Word (Word8, Word16, Word32, Word64)
import           GHC.Generics
import qualified Text.Gigaparsec as P
import qualified Text.Gigaparsec.Char as P
import qualified Text.Gigaparsec.Combinator as P
import qualified Text.Gigaparsec.Errors.ErrorGen as P
import qualified Text.Gigaparsec.Errors.Combinator as P
import qualified Text.Gigaparsec.Token.Descriptions as L
import qualified Text.Gigaparsec.Token.Lexer as L

-- | Type class for parsers associated with types.
class TypeParser a where
  -- | parse a value by its string representation.
  parseType :: String -> Either String a

  default parseType
    :: (Generic a, GTypeParser (Rep a)) => String -> Either String a
  parseType String
s = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Either String (Rep a Any) -> Either String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String (Rep a Any)
forall p. String -> Either String (Rep a p)
forall {k} (f :: k -> *) (p :: k).
GTypeParser f =>
String -> Either String (f p)
gTypeParser String
s
  {-# INLINE parseType #-}

-- | Required (non-empty) String field.
--
-- in POSIX systems, an empty env variable is equivalent to an undefined env
-- variable. To ensure consistency across platforms, we require that all
-- environment variables are non-empty.
instance TypeParser String where
  parseType :: String -> Either String String
  parseType :: String -> Either String String
parseType = Parsec String -> String -> Either String String
forall a. Parsec a -> String -> Either String a
parse (Parsec Char -> Parsec String
forall a. Parsec a -> Parsec [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
P.some Parsec Char
P.item)
  {-# INLINE parseType #-}

-- | Required @Integer@ field (parsed from String).
instance TypeParser Integer where
  parseType :: String -> Either String Integer
  parseType :: String -> Either String Integer
parseType = Parsec Integer -> String -> Either String Integer
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldSigned -> Parsec Integer
forall (canHold :: Bits -> * -> Constraint).
IntegerParsers canHold -> Parsec Integer
L.decimal IntegerParsers CanHoldSigned
integerParser)
  {-# INLINE parseType #-}

-- | Required @Int@ field (parsed from String).
instance TypeParser Int where
  parseType :: String -> Either String Int
  parseType :: String -> Either String Int
parseType = (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Either String Integer -> Either String Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Either String Integer -> Either String Int)
-> (String -> Either String Integer) -> String -> Either String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Integer -> String -> Either String Integer
forall a. Parsec a -> String -> Either String a
parse do
      ErrorGen Integer
-> (Integer -> Bool) -> Parsec Integer -> Parsec Integer
forall a. ErrorGen a -> (a -> Bool) -> Parsec a -> Parsec a
P.filterSWith (String -> ErrorGen Integer
forall a. String -> ErrorGen a
simpleErrorGen String
"Int out of bound")
                    Integer -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
validateInt
                    (IntegerParsers CanHoldSigned -> Parsec Integer
forall (canHold :: Bits -> * -> Constraint).
IntegerParsers canHold -> Parsec Integer
L.decimal IntegerParsers CanHoldSigned
integerParser)
    where
      validateInt :: a -> Bool
validateInt a
n = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int Int
forall a. Bounded a => a
minBound
                   Bool -> Bool -> Bool
&& a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int Int
forall a. Bounded a => a
maxBound
  {-# INLINE parseType #-}

-- | Required @Word@ field (parsed from String).
instance TypeParser Word where
  parseType :: String -> Either String Word
  parseType :: String -> Either String Word
parseType = (Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Integer -> Word) -> Either String Integer -> Either String Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Either String Integer -> Either String Word)
-> (String -> Either String Integer)
-> String
-> Either String Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Integer -> String -> Either String Integer
forall a. Parsec a -> String -> Either String a
parse do
      ErrorGen Integer
-> (Integer -> Bool) -> Parsec Integer -> Parsec Integer
forall a. ErrorGen a -> (a -> Bool) -> Parsec a -> Parsec a
P.filterSWith (String -> ErrorGen Integer
forall a. String -> ErrorGen a
simpleErrorGen String
"Word out of bound")
                    Integer -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
validateWord
                    (IntegerParsers CanHoldUnsigned -> Parsec Integer
forall (canHold :: Bits -> * -> Constraint).
IntegerParsers canHold -> Parsec Integer
L.decimal IntegerParsers CanHoldUnsigned
naturalParser)
    where
      validateWord :: a -> Bool
validateWord a
n = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word Word
forall a. Bounded a => a
maxBound
  {-# INLINE parseType #-}

-- | Required @Bool@ field (parsed from String).
instance TypeParser Bool where
  parseType :: String -> Either String Bool
  parseType :: String -> Either String Bool
parseType = Parsec Bool -> String -> Either String Bool
forall a. Parsec a -> String -> Either String a
parse do
    [Parsec Bool] -> Parsec Bool
forall a. [Parsec a] -> Parsec a
P.choice [String -> Parsec String
P.string String
"True" Parsec String -> Bool -> Parsec Bool
forall a b. Parsec a -> b -> Parsec b
P.$> Bool
True, String -> Parsec String
P.string String
"False" Parsec String -> Bool -> Parsec Bool
forall a b. Parsec a -> b -> Parsec b
P.$> Bool
False]
  {-# INLINE parseType #-}

-- | Required @Int8@ field (parsed from String).
instance TypeParser Int8 where
  parseType :: String -> Either String Int8
  parseType :: String -> Either String Int8
parseType = Parsec Int8 -> String -> Either String Int8
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldSigned -> Parsec Int8
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B8 a =>
IntegerParsers canHold -> Parsec a
L.decimal8 IntegerParsers CanHoldSigned
integerParser)
  {-# INLINE parseType #-}

-- | Required @Int16@ field (parsed from String).
instance TypeParser Int16 where
  parseType :: String -> Either String Int16
  parseType :: String -> Either String Int16
parseType = Parsec Int16 -> String -> Either String Int16
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldSigned -> Parsec Int16
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B16 a =>
IntegerParsers canHold -> Parsec a
L.decimal16 IntegerParsers CanHoldSigned
integerParser)
  {-# INLINE parseType #-}

-- | Required @Int32@ field (parsed from String).
instance TypeParser Int32 where
  parseType :: String -> Either String Int32
  parseType :: String -> Either String Int32
parseType = Parsec Int32 -> String -> Either String Int32
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldSigned -> Parsec Int32
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B32 a =>
IntegerParsers canHold -> Parsec a
L.decimal32 IntegerParsers CanHoldSigned
integerParser)
  {-# INLINE parseType #-}

-- | Required @Int64@ field (parsed from String).
instance TypeParser Int64 where
  parseType :: String -> Either String Int64
  parseType :: String -> Either String Int64
parseType = Parsec Int64 -> String -> Either String Int64
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldSigned -> Parsec Int64
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B64 a =>
IntegerParsers canHold -> Parsec a
L.decimal64 IntegerParsers CanHoldSigned
integerParser)
  {-# INLINE parseType #-}

-- | Required @Word8@ field (parsed from String).
instance TypeParser Word8 where
  parseType :: String -> Either String Word8
  parseType :: String -> Either String Word8
parseType = Parsec Word8 -> String -> Either String Word8
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldUnsigned -> Parsec Word8
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B8 a =>
IntegerParsers canHold -> Parsec a
L.decimal8 IntegerParsers CanHoldUnsigned
naturalParser)
  {-# INLINE parseType #-}

-- | Required @Word16@ field (parsed from String).
instance TypeParser Word16 where
  parseType :: String -> Either String Word16
  parseType :: String -> Either String Word16
parseType = Parsec Word16 -> String -> Either String Word16
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldUnsigned -> Parsec Word16
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B16 a =>
IntegerParsers canHold -> Parsec a
L.decimal16 IntegerParsers CanHoldUnsigned
naturalParser)
  {-# INLINE parseType #-}

-- | Required @Word32@ field (parsed from String).
instance TypeParser Word32 where
  parseType :: String -> Either String Word32
  parseType :: String -> Either String Word32
parseType = Parsec Word32 -> String -> Either String Word32
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldUnsigned -> Parsec Word32
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B32 a =>
IntegerParsers canHold -> Parsec a
L.decimal32 IntegerParsers CanHoldUnsigned
naturalParser)
  {-# INLINE parseType #-}

-- | Required @Word64@ field (parsed from String).
instance TypeParser Word64 where
  parseType :: String -> Either String Word64
  parseType :: String -> Either String Word64
parseType = Parsec Word64 -> String -> Either String Word64
forall a. Parsec a -> String -> Either String a
parse (IntegerParsers CanHoldUnsigned -> Parsec Word64
forall a (canHold :: Bits -> * -> Constraint).
canHold 'B64 a =>
IntegerParsers canHold -> Parsec a
L.decimal64 IntegerParsers CanHoldUnsigned
naturalParser)
  {-# INLINE parseType #-}

-- | Required @()@ field (parsed from String).
instance TypeParser () where
  parseType :: String -> Either String ()
  parseType :: String -> Either String ()
parseType = Parsec () -> String -> Either String ()
forall a. Parsec a -> String -> Either String a
parse (String -> Parsec String
P.string String
"()" Parsec String -> () -> Parsec ()
forall a b. Parsec a -> b -> Parsec b
P.$> ())
  {-# INLINE parseType #-}

-- | Optional fields (@Maybe a@).
instance TypeParser a => TypeParser (Maybe a) where
  parseType :: String -> Either String (Maybe a)
  parseType :: String -> Either String (Maybe a)
parseType String
"" = Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
  parseType String
s  = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String a
forall a. TypeParser a => String -> Either String a
parseType String
s
  {-# INLINE parseType #-}


--------------------------------------------------------------------------------
-- Generic instances
--------------------------------------------------------------------------------

-- | Generic validation class.
class GTypeParser f where
  gTypeParser :: String -> Either String (f p)


--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

simpleLexeme :: L.Lexeme
simpleLexeme :: Lexeme
simpleLexeme = Lexer -> Lexeme
L.nonlexeme (LexicalDesc -> Lexer
L.mkLexer LexicalDesc
L.plain)
{-# INLINE simpleLexeme #-}

integerParser :: L.IntegerParsers L.CanHoldSigned
integerParser :: IntegerParsers CanHoldSigned
integerParser = Lexeme -> IntegerParsers CanHoldSigned
L.integer Lexeme
simpleLexeme
{-# INLINE integerParser #-}

naturalParser :: L.IntegerParsers L.CanHoldUnsigned
naturalParser :: IntegerParsers CanHoldUnsigned
naturalParser = Lexeme -> IntegerParsers CanHoldUnsigned
L.natural Lexeme
simpleLexeme
{-# INLINE naturalParser #-}

parseResultToEither :: P.Result String a -> Either String a
parseResultToEither :: forall a. Result String a -> Either String a
parseResultToEither (P.Failure String
e) = String -> Either String a
forall a b. a -> Either a b
Left (String -> String
forall a. Show a => a -> String
show String
e)
parseResultToEither (P.Success a
a) = a -> Either String a
forall a b. b -> Either a b
Right a
a
{-# INLINE parseResultToEither #-}

parse :: P.Parsec a -> String -> Either String a
parse :: forall a. Parsec a -> String -> Either String a
parse Parsec a
parser = Result String a -> Either String a
forall a. Result String a -> Either String a
parseResultToEither (Result String a -> Either String a)
-> (String -> Result String a) -> String -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec a -> String -> Result String a
forall err a.
ErrorBuilder err =>
Parsec a -> String -> Result err a
P.parse (Parsec a
parser Parsec a -> (a -> Parsec a) -> Parsec a
forall a b. Parsec a -> (a -> Parsec b) -> Parsec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Parsec ()
P.eof Parsec () -> a -> Parsec a
forall a b. Parsec a -> b -> Parsec b
P.$>))
{-# INLINE parse #-}

simpleErrorGen :: String -> P.ErrorGen a
simpleErrorGen :: forall a. String -> ErrorGen a
simpleErrorGen String
msg = case ErrorGen a
forall a. ErrorGen a
P.vanillaGen of
  P.VanillaGen {a -> Maybe String
a -> UnexpectedItem
a -> Word -> Word
unexpected :: a -> UnexpectedItem
reason :: a -> Maybe String
adjustWidth :: a -> Word -> Word
adjustWidth :: forall a. ErrorGen a -> a -> Word -> Word
unexpected :: forall a. ErrorGen a -> a -> UnexpectedItem
reason :: forall a. ErrorGen a -> a -> Maybe String
..} -> P.VanillaGen { reason :: a -> Maybe String
reason = Maybe String -> a -> Maybe String
forall a b. a -> b -> a
const (String -> Maybe String
forall a. a -> Maybe a
Just String
msg), a -> UnexpectedItem
a -> Word -> Word
unexpected :: a -> UnexpectedItem
adjustWidth :: a -> Word -> Word
adjustWidth :: a -> Word -> Word
unexpected :: a -> UnexpectedItem
.. }
  ErrorGen a
impossible        -> ErrorGen a
impossible
{-# INLINE simpleErrorGen #-}