TypeParser.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}

-- |
-- 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.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Tuple ( Solo(..) )
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Generics
import Text.Gigaparsec qualified as P
import Text.Gigaparsec.Char qualified as P
import Text.Gigaparsec.Combinator qualified as P
import Text.Gigaparsec.Errors.ErrorGen qualified as P
import Text.Gigaparsec.Errors.Combinator qualified as P
import Text.Gigaparsec.Token.Descriptions qualified as L
import Text.Gigaparsec.Token.Lexer qualified 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 s = to <$> gTypeParser s
  {-# INLINE parseType #-}

  -- | Result to use when the environment variable is absent (empty string).
  --
  -- The default signals that the variable is required. Override this for
  -- types that have a meaningful absence value, e.g. 'Maybe' returns
  -- 'Right' 'Nothing'.
  parseMissing :: Either String a
  parseMissing = Left "missing required environment variable"
  {-# INLINE parseMissing #-}

  -- | Parse a value, converting 'Either' to 'Maybe' and dropping any error messages.
  parseType' :: String -> Maybe a
  parseType' str = case parseType str of
    Right val -> Just val
    Left _    -> Nothing
  {-# 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 = parse (P.label (Set.singleton "a non-empty string") (P.some P.item))
  {-# INLINE parseType #-}

-- | Required @Integer@ field (parsed from String).
instance TypeParser Integer where
  parseType :: String -> Either String Integer
  parseType = parse (P.label (Set.singleton "an integer") (L.decimal integerParser))
  {-# INLINE parseType #-}

-- | Required @Int@ field (parsed from String).
instance TypeParser Int where
  parseType :: String -> Either String Int
  parseType = (fromInteger <$>) . parse do
      P.filterSWith (simpleErrorGen boundsMsg) validateInt
        $ P.label (Set.singleton "an integer") (L.decimal integerParser)
    where
      validateInt n = n >= fromIntegral @Int minBound
                   && n <= fromIntegral @Int maxBound
      boundsMsg = "integer out of range for Int (valid: "
               ++ show (minBound :: Int) ++ " to " ++ show (maxBound :: Int) ++ ")"
  {-# INLINE parseType #-}

-- | Required @Word@ field (parsed from String).
instance TypeParser Word where
  parseType :: String -> Either String Word
  parseType = (fromInteger <$>) . parse do
      P.filterSWith (simpleErrorGen boundsMsg) validateWord
        $ P.label (Set.singleton "a natural number") (L.decimal naturalParser)
    where
      validateWord n = n <= fromIntegral @Word maxBound
      boundsMsg = "natural number out of range for Word (valid: 0 to "
               ++ show (maxBound :: Word) ++ ")"
  {-# INLINE parseType #-}

-- | Required @Bool@ field (parsed from String).
--
-- Accepts only @True@ or @False@ (case-sensitive). For a more lenient
-- boolean parser (accepting @true@, @1@, @t@, etc.) use the @DefaultBool@
-- witness.
instance TypeParser Bool where
  parseType :: String -> Either String Bool
  parseType = parse $ P.label (Set.fromList ["True", "False"])
    $ P.choice [P.string "True" P.$> True, P.string "False" P.$> False]
  {-# INLINE parseType #-}

-- | Required @Int8@ field (parsed from String).
instance TypeParser Int8 where
  parseType :: String -> Either String Int8
  parseType = parse (P.label (Set.singleton "an integer") (L.decimal8 integerParser))
  {-# INLINE parseType #-}

-- | Required @Int16@ field (parsed from String).
instance TypeParser Int16 where
  parseType :: String -> Either String Int16
  parseType = parse (P.label (Set.singleton "an integer") (L.decimal16 integerParser))
  {-# INLINE parseType #-}

-- | Required @Int32@ field (parsed from String).
instance TypeParser Int32 where
  parseType :: String -> Either String Int32
  parseType = parse (P.label (Set.singleton "an integer") (L.decimal32 integerParser))
  {-# INLINE parseType #-}

-- | Required @Int64@ field (parsed from String).
instance TypeParser Int64 where
  parseType :: String -> Either String Int64
  parseType = parse (P.label (Set.singleton "an integer") (L.decimal64 integerParser))
  {-# INLINE parseType #-}

-- | Required @Word8@ field (parsed from String).
instance TypeParser Word8 where
  parseType :: String -> Either String Word8
  parseType = parse (P.label (Set.singleton "a natural number") (L.decimal8 naturalParser))
  {-# INLINE parseType #-}

-- | Required @Word16@ field (parsed from String).
instance TypeParser Word16 where
  parseType :: String -> Either String Word16
  parseType = parse (P.label (Set.singleton "a natural number") (L.decimal16 naturalParser))
  {-# INLINE parseType #-}

-- | Required @Word32@ field (parsed from String).
instance TypeParser Word32 where
  parseType :: String -> Either String Word32
  parseType = parse (P.label (Set.singleton "a natural number") (L.decimal32 naturalParser))
  {-# INLINE parseType #-}

-- | Required @Word64@ field (parsed from String).
instance TypeParser Word64 where
  parseType :: String -> Either String Word64
  parseType = parse (P.label (Set.singleton "a natural number") (L.decimal64 naturalParser))
  {-# INLINE parseType #-}

-- | Required strict @Text@ field (parsed from String).
instance TypeParser T.Text where
  parseType :: String -> Either String T.Text
  parseType = fmap T.pack . parseType
  {-# INLINE parseType #-}

-- | Required lazy @Text@ field (parsed from String).
instance TypeParser TL.Text where
  parseType :: String -> Either String TL.Text
  parseType = fmap TL.pack . parseType
  {-# INLINE parseType #-}

-- | Required @()@ field (parsed from String).
instance TypeParser () where
  parseType :: String -> Either String ()
  parseType = parse (P.label (Set.singleton "\"()\"") (P.string "()" P.$> ()))
  {-# INLINE parseType #-}

-- | Solo fields isomorphic to the original (@Solo a@).
instance TypeParser a => TypeParser (Solo a) where
  parseType :: String -> Either String (Solo a)
#if MIN_VERSION_base(4,18,0)
  parseType s = MkSolo <$> parseType s
#else
  parseType s = Solo <$> parseType s
#endif
  {-# INLINE parseType #-}

-- | Optional fields (@Maybe a@).
--
-- An absent (empty) value maps to 'Nothing'; a non-empty value is parsed
-- by the inner 'TypeParser'.
instance TypeParser a => TypeParser (Maybe a) where
  -- | An absent optional field is 'Nothing', not an error.
  parseMissing :: Either String (Maybe a)
  parseMissing = Right Nothing

  parseType :: String -> Either String (Maybe a)
  parseType "" = Right Nothing
  parseType s  = Just <$> parseType s
  {-# INLINE parseType #-}


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

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


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

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

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

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

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

parse :: P.Parsec a -> String -> Either String a
parse parser = parseResultToEither . P.parse (parser >>= (P.eof P.$>))
{-# INLINE parse #-}

simpleErrorGen :: String -> P.ErrorGen a
simpleErrorGen msg = case P.vanillaGen of
  P.VanillaGen {..} -> P.VanillaGen { reason = const (Just msg), .. }
  impossible        -> impossible
{-# INLINE simpleErrorGen #-}