------------------------------------------------------------------------------
-- |
-- Module      : Data.TTC
-- Description : textual type classes
-- Copyright   : Copyright (c) 2019-2020 Travis Cardwell
-- License     : MIT
--
-- TTC, an initialism of /Textual Type Classes/, is a library that provides
-- type classes for conversion between data types and textual data types
-- (strings).
--
-- This library is meant to be imported qualified, as follows:
--
-- @
-- import qualified Data.TTC as TTC
-- @
------------------------------------------------------------------------------

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.TTC
  ( -- * Textual
    Textual
  , convert
    -- ** \"To\" Conversions
    -- $TextualTo
  , toS
  , toT
  , toTL
  , toBS
  , toBSL
    -- ** \"From\" Conversions
    -- $TextualFrom
  , fromS
  , fromT
  , fromTL
  , fromBS
  , fromBSL
    -- ** \"As\" Conversions
    -- $TextualAs
  , asS
  , asT
  , asTL
  , asBS
  , asBSL
    -- ** Other Conversions
    -- $TextualOther
  , toTLB
  , fromTLB
  , toBSB
  , fromBSB
  , toSBS
  , fromSBS
    -- * Render
  , Render(..)
    -- ** Rendering Specific Types
    -- $RenderSpecific
  , renderS
  , renderT
  , renderTL
  , renderBS
  , renderBSL
    -- ** Render Utilities
  , renderWithShow
    -- * Parse
  , Parse(..)
    -- ** Parsing From Specific Types
    -- $ParseSpecific
  , parseS
  , parseT
  , parseTL
  , parseBS
  , parseBSL
    -- ** 'Maybe' Parsing
    -- $ParseMaybe
  , parseMaybe
  , parseMaybeS
  , parseMaybeT
  , parseMaybeTL
  , parseMaybeBS
  , parseMaybeBSL
    -- ** Unsafe Parsing
    -- $ParseUnsafe
  , parseUnsafe
  , parseUnsafeS
  , parseUnsafeT
  , parseUnsafeTL
  , parseUnsafeBS
  , parseUnsafeBSL
    -- ** Parse Utilities
  , parseEnum
  , parseEnum'
  , parseWithRead
  , parseWithRead'
  , maybeParseWithRead
  , readsEnum
  , readsWithParse
    -- ** Constant Validation
  , valid
  , validOf
  , mkValid
  , untypedValidOf
  , mkUntypedValid
  , mkUntypedValidQQ
  ) where

-- https://hackage.haskell.org/package/base
import Data.Proxy (Proxy(Proxy), asProxyTypeOf)
import Text.Read (readMaybe)

-- https://hackage.haskell.org/package/bytestring
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS

-- https://hackage.haskell.org/package/template-haskell
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as Q
import qualified Language.Haskell.TH.Syntax as THS

-- https://hackage.haskell.org/package/text
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Encoding as TLE

------------------------------------------------------------------------------
-- $Textual

-- | The 'Textual' type class is used to convert between the following textual
-- data types:
--
-- * 'String' (@S@)
-- * Strict 'T.Text' (@T@)
-- * Lazy 'TL.Text' (@TL@)
-- * Strict 'BS.ByteString' (@BS@)
-- * Lazy 'BSL.ByteString' (@BSL@)
--
-- @ByteString@ values are assumed to be UTF-8 encoded text.  Invalid bytes
-- are replaced with the Unicode replacement character @U+FFFD@.  In cases
-- where different behavior is required, process @ByteString@ values /before/
-- using this class.
--
-- The key feature of this type class is that it has a single type variable,
-- making it easy to write functions that accepts arguments and/or returns
-- values that may be any of the supported textual data types.
--
-- Note that support for additional data types cannot be implemented by
-- writing instances.  Adding support for additional data types would require
-- changing the class definition itself.  This is the price paid for having
-- only one type variable instead of two.
class Textual t where
  -- | Convert to a 'String'
  toS :: t -> String

  -- | Convert to strict 'T.Text'
  toT :: t -> T.Text

  -- | Convert to lazy 'TL.Text'
  toTL :: t -> TL.Text

  -- | Convert to a strict 'BS.ByteString'
  toBS :: t -> BS.ByteString

  -- | Convert to a lazy 'BS.ByteString'
  toBSL :: t -> BSL.ByteString

  -- | Convert between any supported textual data types
  convert :: Textual t' => t' -> t

instance Textual String where
  toS :: String -> String
toS = String -> String
forall a. a -> a
id
  toT :: String -> Text
toT = String -> Text
T.pack
  toTL :: String -> Text
toTL = String -> Text
TL.pack
  toBS :: String -> ByteString
toBS = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  toBSL :: String -> ByteString
toBSL = Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack
  convert :: t' -> String
convert = t' -> String
forall t'. Textual t' => t' -> String
toS
  {-# INLINE toS #-}
  {-# INLINE toT #-}
  {-# INLINE toTL #-}
  {-# INLINE toBS #-}
  {-# INLINE toBSL #-}
  {-# INLINE convert #-}

instance Textual T.Text where
  toS :: Text -> String
toS = Text -> String
T.unpack
  toT :: Text -> Text
toT = Text -> Text
forall a. a -> a
id
  toTL :: Text -> Text
toTL = Text -> Text
TL.fromStrict
  toBS :: Text -> ByteString
toBS = Text -> ByteString
TE.encodeUtf8
  toBSL :: Text -> ByteString
toBSL = Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
  convert :: t' -> Text
convert = t' -> Text
forall t'. Textual t' => t' -> Text
toT
  {-# INLINE toS #-}
  {-# INLINE toT #-}
  {-# INLINE toTL #-}
  {-# INLINE toBS #-}
  {-# INLINE toBSL #-}
  {-# INLINE convert #-}

instance Textual TL.Text where
  toS :: Text -> String
toS = Text -> String
TL.unpack
  toT :: Text -> Text
toT = Text -> Text
TL.toStrict
  toTL :: Text -> Text
toTL = Text -> Text
forall a. a -> a
id
  toBS :: Text -> ByteString
toBS = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8
  toBSL :: Text -> ByteString
toBSL = Text -> ByteString
TLE.encodeUtf8
  convert :: t' -> Text
convert = t' -> Text
forall t'. Textual t' => t' -> Text
toTL
  {-# INLINE toS #-}
  {-# INLINE toT #-}
  {-# INLINE toTL #-}
  {-# INLINE toBS #-}
  {-# INLINE toBSL #-}
  {-# INLINE convert #-}

instance Textual BS.ByteString where
  toS :: ByteString -> String
toS = Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode
  toT :: ByteString -> Text
toT = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode
  toTL :: ByteString -> Text
toTL = OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
TEE.lenientDecode (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict
  toBS :: ByteString -> ByteString
toBS = ByteString -> ByteString
forall a. a -> a
id
  toBSL :: ByteString -> ByteString
toBSL = ByteString -> ByteString
BSL.fromStrict
  convert :: t' -> ByteString
convert = t' -> ByteString
forall t'. Textual t' => t' -> ByteString
toBS
  {-# INLINE toS #-}
  {-# INLINE toT #-}
  {-# INLINE toTL #-}
  {-# INLINE toBS #-}
  {-# INLINE toBSL #-}
  {-# INLINE convert #-}

instance Textual BSL.ByteString where
  toS :: ByteString -> String
toS = Text -> String
TL.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
TEE.lenientDecode
  toT :: ByteString -> Text
toT = Text -> Text
TL.toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
TEE.lenientDecode
  toTL :: ByteString -> Text
toTL = OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
TEE.lenientDecode
  toBS :: ByteString -> ByteString
toBS = ByteString -> ByteString
BSL.toStrict
  toBSL :: ByteString -> ByteString
toBSL = ByteString -> ByteString
forall a. a -> a
id
  convert :: t' -> ByteString
convert = t' -> ByteString
forall t'. Textual t' => t' -> ByteString
toBSL
  {-# INLINE toS #-}
  {-# INLINE toT #-}
  {-# INLINE toTL #-}
  {-# INLINE toBS #-}
  {-# INLINE toBSL #-}
  {-# INLINE convert #-}

-- $TextualTo
--
-- These functions are equivalent to 'convert', but they specify the type
-- being converted to.  Use them to avoid having to write type annotations in
-- cases where the type is ambiguous.

-- $TextualFrom
--
-- These functions are equivalent to 'convert', but they specify the type
-- being converted from.  Use them to avoid having to write type annotations
-- in cases where the type is ambiguous.

-- | Convert from a 'String'
fromS :: Textual t => String -> t
fromS :: String -> t
fromS = String -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromS #-}

-- | Convert from strict 'T.Text'
fromT :: Textual t => T.Text -> t
fromT :: Text -> t
fromT = Text -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromT #-}

-- | Convert from lazy 'TL.Text'
fromTL :: Textual t => TL.Text -> t
fromTL :: Text -> t
fromTL = Text -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromTL #-}

-- | Convert from a strict 'BS.ByteString'
fromBS :: Textual t => BS.ByteString -> t
fromBS :: ByteString -> t
fromBS = ByteString -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromBS #-}

-- | Convert from a lazy 'BSL.ByteString'
fromBSL :: Textual t => BSL.ByteString -> t
fromBSL :: ByteString -> t
fromBSL = ByteString -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromBSL #-}

-- $TextualAs
--
-- These functions are used to convert a 'Textual' argument of a function to a
-- specific type.  Use them to reduce boilerplate in small function
-- definitions.

-- | Convert an argument to a 'String'
asS :: Textual t => (String -> a) -> t -> a
asS :: (String -> a) -> t -> a
asS String -> a
f = String -> a
f (String -> a) -> (t -> String) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> String
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE asS #-}

-- | Convert an argument to strict 'T.Text'
asT :: Textual t => (T.Text -> a) -> t -> a
asT :: (Text -> a) -> t -> a
asT Text -> a
f = Text -> a
f (Text -> a) -> (t -> Text) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Text
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE asT #-}

-- | Convert an argument to lazy 'TL.Text'
asTL :: Textual t => (TL.Text -> a) -> t -> a
asTL :: (Text -> a) -> t -> a
asTL Text -> a
f = Text -> a
f (Text -> a) -> (t -> Text) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Text
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE asTL #-}

-- | Convert an argument to a strict 'BS.ByteString'
asBS :: Textual t => (BS.ByteString -> a) -> t -> a
asBS :: (ByteString -> a) -> t -> a
asBS ByteString -> a
f = ByteString -> a
f (ByteString -> a) -> (t -> ByteString) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE asBS #-}

-- | Convert an argument to a lazy 'BSL.ByteString'
asBSL :: Textual t => (BSL.ByteString -> a) -> t -> a
asBSL :: (ByteString -> a) -> t -> a
asBSL ByteString -> a
f = ByteString -> a
f (ByteString -> a) -> (t -> ByteString) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE asBSL #-}

-- $TextualOther
--
-- These functions are used to convert to/from the following other textual
-- data types:
--
-- * @Text@ 'TLB.Builder' (@TLB@)
-- * @ByteString@ 'BSB.Builder' (@BSB@)
-- * 'SBS.ShortByteString' (@SBS@)

-- | Convert to a @Text@ 'TLB.Builder'
toTLB :: Textual t => t -> TLB.Builder
toTLB :: t -> Builder
toTLB = Text -> Builder
TLB.fromLazyText (Text -> Builder) -> (t -> Text) -> t -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Text
forall t t'. (Textual t, Textual t') => t' -> t
convert

-- | Convert from a @Text@ 'TLB.Builder'
fromTLB :: Textual t => TLB.Builder -> t
fromTLB :: Builder -> t
fromTLB = Text -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert (Text -> t) -> (Builder -> Text) -> Builder -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TLB.toLazyText

-- | Convert to a @ByteString@ 'BSB.Builder'
toBSB :: Textual t => t -> BSB.Builder
toBSB :: t -> Builder
toBSB = ByteString -> Builder
BSB.lazyByteString (ByteString -> Builder) -> (t -> ByteString) -> t -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall t t'. (Textual t, Textual t') => t' -> t
convert

-- | Convert from a @ByteString@ 'BSB.Builder'
fromBSB :: Textual t => BSB.Builder -> t
fromBSB :: Builder -> t
fromBSB = ByteString -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert (ByteString -> t) -> (Builder -> ByteString) -> Builder -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString

-- | Convert to a 'SBS.ShortByteString'
toSBS :: Textual t => t -> SBS.ShortByteString
toSBS :: t -> ShortByteString
toSBS = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString)
-> (t -> ByteString) -> t -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall t t'. (Textual t, Textual t') => t' -> t
convert

-- | Convert from a 'SBS.ShortByteString'
fromSBS :: Textual t => SBS.ShortByteString -> t
fromSBS :: ShortByteString -> t
fromSBS = ByteString -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert (ByteString -> t)
-> (ShortByteString -> ByteString) -> ShortByteString -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
SBS.fromShort

------------------------------------------------------------------------------
-- $Render

-- | The 'Render' type class renders a data type as a textual data type.
--
-- There are no default instances for the 'Render' type class, so that all
-- instances can be customized per project when desired.  Instances for some
-- basic data types are available in "Data.TTC.Instances".
--
-- See the @uname@ and @prompt@ example programs in the @examples@ directory.
class Render a where
  render :: Textual t => a -> t

-- $RenderSpecific
--
-- These functions are equivalent to 'render', but they specify the type being
-- rendered to.  Use them to avoid having to write type annotations in cases
-- where the type is ambiguous.

-- | Render to a 'String'
renderS :: Render a => a -> String
renderS :: a -> String
renderS = a -> String
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderS #-}

-- | Render to strict 'T.Text'
renderT :: Render a => a -> T.Text
renderT :: a -> Text
renderT = a -> Text
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderT #-}

-- | Render to lazy 'TL.Text'
renderTL :: Render a => a -> TL.Text
renderTL :: a -> Text
renderTL = a -> Text
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderTL #-}

-- | Render to a strict 'BS.ByteString'
renderBS :: Render a => a -> BS.ByteString
renderBS :: a -> ByteString
renderBS = a -> ByteString
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderBS #-}

-- | Render to a lazy 'BSL.ByteString'
renderBSL :: Render a => a -> BSL.ByteString
renderBSL :: a -> ByteString
renderBSL = a -> ByteString
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderBSL #-}

-- $RenderUtils

-- | Render a value to a textual data type using the 'Show' instance
renderWithShow :: (Show a, Textual t) => a -> t
renderWithShow :: a -> t
renderWithShow = String -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert (String -> t) -> (a -> String) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
{-# INLINE renderWithShow #-}

------------------------------------------------------------------------------
-- $Parse

-- | The 'Parse' type class parses a data type from a textual data type.
--
-- There are no default instances for the 'Parse' type class, so that all
-- instances can be customized per project when desired.  Instances for some
-- basic data types are available in "Data.TTC.Instances".
--
-- See the @uname@ and @prompt@ example programs in the @examples@ directory.
class Parse a where
  parse :: (Textual t, Textual e) => t -> Either e a

-- This function is equivalent to 'parse' with the error type fixed to
-- 'String', used internally when the error is ignored.
parse' :: (Parse a, Textual t) => t -> Either String a
parse' :: t -> Either String a
parse' = t -> Either String a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parse' #-}

-- $ParseSpecific
--
-- These functions are equivalent to 'parse', but they specify the type being
-- parsed from.  Use them to avoid having to write type annotations in cases
-- where the type is ambiguous.

-- | Parse from a 'String'
parseS :: (Parse a, Textual e) => String -> Either e a
parseS :: String -> Either e a
parseS = String -> Either e a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parseS #-}

-- | Parse from strict 'T.Text'
parseT :: (Parse a, Textual e) => T.Text -> Either e a
parseT :: Text -> Either e a
parseT = Text -> Either e a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parseT #-}

-- | Parse from lazy 'TL.Text'
parseTL :: (Parse a, Textual e) => TL.Text -> Either e a
parseTL :: Text -> Either e a
parseTL = Text -> Either e a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parseTL #-}

-- | Parse from a strict 'BS.ByteString'
parseBS :: (Parse a, Textual e) => BS.ByteString -> Either e a
parseBS :: ByteString -> Either e a
parseBS = ByteString -> Either e a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parseBS #-}

-- | Parse from a lazy 'BSL.ByteString'
parseBSL :: (Parse a, Textual e) => BSL.ByteString -> Either e a
parseBSL :: ByteString -> Either e a
parseBSL = ByteString -> Either e a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parseBSL #-}

-- $ParseMaybe
--
-- The 'parseMaybe' function parses to a 'Maybe' type instead of an 'Either'
-- type.  The rest of the functions are equivalent to 'parseMaybe', but they
-- specify the type being parsed from.  Use them to avoid having to write type
-- annotations in cases where the type is ambiguous.

-- | Parse to a 'Maybe' type
parseMaybe :: (Parse a, Textual t) => t -> Maybe a
parseMaybe :: t -> Maybe a
parseMaybe = (String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> String -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either String a -> Maybe a)
-> (t -> Either String a) -> t -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Either String a
forall a t. (Parse a, Textual t) => t -> Either String a
parse'
{-# INLINE parseMaybe #-}

-- | Parse from a 'String' to a 'Maybe' type
parseMaybeS :: Parse a => String -> Maybe a
parseMaybeS :: String -> Maybe a
parseMaybeS = String -> Maybe a
forall a t. (Parse a, Textual t) => t -> Maybe a
parseMaybe
{-# INLINE parseMaybeS #-}

-- | Parse from strict 'T.Text' to a 'Maybe' type
parseMaybeT :: Parse a => T.Text -> Maybe a
parseMaybeT :: Text -> Maybe a
parseMaybeT = Text -> Maybe a
forall a t. (Parse a, Textual t) => t -> Maybe a
parseMaybe
{-# INLINE parseMaybeT #-}

-- | Parse from lazy 'TL.Text' to a 'Maybe' type
parseMaybeTL :: Parse a => TL.Text -> Maybe a
parseMaybeTL :: Text -> Maybe a
parseMaybeTL = Text -> Maybe a
forall a t. (Parse a, Textual t) => t -> Maybe a
parseMaybe
{-# INLINE parseMaybeTL #-}

-- | Parse from a strict 'BS.ByteString' to a 'Maybe' type
parseMaybeBS :: Parse a => BS.ByteString -> Maybe a
parseMaybeBS :: ByteString -> Maybe a
parseMaybeBS = ByteString -> Maybe a
forall a t. (Parse a, Textual t) => t -> Maybe a
parseMaybe
{-# INLINE parseMaybeBS #-}

-- | Parse from a lazy 'BSL.ByteString' to a 'Maybe' type
parseMaybeBSL :: Parse a => BSL.ByteString -> Maybe a
parseMaybeBSL :: ByteString -> Maybe a
parseMaybeBSL = ByteString -> Maybe a
forall a t. (Parse a, Textual t) => t -> Maybe a
parseMaybe
{-# INLINE parseMaybeBSL #-}

-- $ParseUnsafe
--
-- The 'parseUnsafe' function raises an exception on error instead of using an
-- 'Either' type.  It should only be used when an error is not possible.  The
-- rest of the functions are equivalent to 'parseUnsafe', but they specify the
-- type being parsed from.  Use them to avoid having to write type annotations
-- in cases where the type is ambiguous.

-- | Unsafely parse
parseUnsafe :: (Parse a, Textual t) => t -> a
parseUnsafe :: t -> a
parseUnsafe = (String -> a) -> (a -> a) -> Either String a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"parseUnsafe: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) a -> a
forall a. a -> a
id (Either String a -> a) -> (t -> Either String a) -> t -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Either String a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse
{-# INLINE parseUnsafe #-}

-- | Unsafely parse to a 'String'
parseUnsafeS :: Parse a => String -> a
parseUnsafeS :: String -> a
parseUnsafeS = String -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeS #-}

-- | Unsafely parse to strict 'T.Text'
parseUnsafeT :: Parse a => T.Text -> a
parseUnsafeT :: Text -> a
parseUnsafeT = Text -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeT #-}

-- | Unsafely parse to lazy 'TL.Text'
parseUnsafeTL :: Parse a => TL.Text -> a
parseUnsafeTL :: Text -> a
parseUnsafeTL = Text -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeTL #-}

-- | Unsafely parse to a strict 'BS.ByteString'
parseUnsafeBS :: Parse a => BS.ByteString -> a
parseUnsafeBS :: ByteString -> a
parseUnsafeBS = ByteString -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeBS #-}

-- | Unsafely parse to a lazy 'BSL.ByteString'
parseUnsafeBSL :: Parse a => BSL.ByteString -> a
parseUnsafeBSL :: ByteString -> a
parseUnsafeBSL = ByteString -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeBSL #-}

-- $ParseUtils

-- | Parse a value in an enumeration
--
-- This function is intended to be used with types that have few choices, as
-- the implementation uses a linear algorithm.
--
-- See the @enum@ example program in the @examples@ directory.
parseEnum
  :: (Bounded a, Enum a, Render a, Textual t)
  => Bool        -- ^ case-insensitive when 'True'
  -> Bool        -- ^ accept unique prefixes when 'True'
  -> e           -- ^ invalid input error
  -> e           -- ^ ambiguous input error
  -> t           -- ^ textual input to parse
  -> Either e a  -- ^ error or parsed value
parseEnum :: Bool -> Bool -> e -> e -> t -> Either e a
parseEnum Bool
allowCI Bool
allowPrefix e
invalidError e
ambiguousError t
t =
    let t' :: Text
t' = Text -> Text
norm (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ t -> Text
forall t'. Textual t' => t' -> Text
toT t
t
    in  case [a
v | a
v <- [a
forall a. Bounded a => a
minBound ..], Text
t' Text -> Text -> Bool
`match` Text -> Text
norm (a -> Text
forall a t. (Render a, Textual t) => a -> t
render a
v)] of
          [a
v] -> a -> Either e a
forall a b. b -> Either a b
Right a
v
          []  -> e -> Either e a
forall a b. a -> Either a b
Left e
invalidError
          [a]
_   -> e -> Either e a
forall a b. a -> Either a b
Left e
ambiguousError
  where
    norm :: T.Text -> T.Text
    norm :: Text -> Text
norm = if Bool
allowCI then Text -> Text
T.toLower else Text -> Text
forall a. a -> a
id

    match :: T.Text -> T.Text -> Bool
    match :: Text -> Text -> Bool
match = if Bool
allowPrefix then Text -> Text -> Bool
T.isPrefixOf else Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | Parse a value in an enumeration, with 'String' error messages
--
-- The following English error messages are returned:
--
-- * \"invalid {name}\" when there are no matches
-- * \"ambiguous {name}\" when there is more than one match
parseEnum'
  :: (Bounded a, Enum a, Render a, Textual t)
  => String           -- ^ name to include in error messages
  -> Bool             -- ^ case-insensitive when 'True'
  -> Bool             -- ^ accept unique prefixes when 'True'
  -> t                -- ^ textual input to parse
  -> Either String a  -- ^ error or parsed value
parseEnum' :: String -> Bool -> Bool -> t -> Either String a
parseEnum' String
name Bool
allowCI Bool
allowPrefix =
    Bool -> Bool -> String -> String -> t -> Either String a
forall a t e.
(Bounded a, Enum a, Render a, Textual t) =>
Bool -> Bool -> e -> e -> t -> Either e a
parseEnum Bool
allowCI Bool
allowPrefix (String
"invalid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (String
"ambiguous " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
{-# INLINEABLE parseEnum' #-}

-- | Parse a value using the 'Read' instance
parseWithRead
  :: (Read a, Textual t)
  => e           -- ^ invalid input error
  -> t           -- ^ textual input to parse
  -> Either e a  -- ^ error or parsed value
parseWithRead :: e -> t -> Either e a
parseWithRead e
invalidError = Either e a -> (a -> Either e a) -> Maybe a -> Either e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e a
forall a b. a -> Either a b
Left e
invalidError) a -> Either e a
forall a b. b -> Either a b
Right (Maybe a -> Either e a) -> (t -> Maybe a) -> t -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (t -> String) -> t -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> String
forall t'. Textual t' => t' -> String
toS
{-# INLINEABLE parseWithRead #-}

-- | Parse a value using the 'Read' instance, with 'String' error messages
--
-- The following English error message is returned:
--
-- * \"invalid {name}\" when the parse fails
parseWithRead'
  :: (Read a, Textual t, Textual e)
  => String      -- ^ name to include in error messages
  -> t           -- ^ textual input to parse
  -> Either e a  -- ^ error or parsed value
parseWithRead' :: String -> t -> Either e a
parseWithRead' String
name = e -> t -> Either e a
forall a t e. (Read a, Textual t) => e -> t -> Either e a
parseWithRead (String -> e
forall t. Textual t => String -> t
fromS (String -> e) -> String -> e
forall a b. (a -> b) -> a -> b
$ String
"invalid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
{-# INLINEABLE parseWithRead' #-}

-- | Parse a value to a 'Maybe' type using the 'Read' instance
maybeParseWithRead
  :: (Read a, Textual t)
  => t           -- ^ textual input to parse
  -> Maybe a  -- ^ error or parsed value
maybeParseWithRead :: t -> Maybe a
maybeParseWithRead = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (t -> String) -> t -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> String
forall t'. Textual t' => t' -> String
toS

-- | Implement 'ReadS' using 'parseEnum'
--
-- This implementation expects all of the input to be consumed.
readsEnum
  :: (Bounded a, Enum a, Render a)
  => Bool  -- ^ case-insensitive when 'True'
  -> Bool  -- ^ accept unique prefixes when 'True'
  -> ReadS a
readsEnum :: Bool -> Bool -> ReadS a
readsEnum Bool
allowCI Bool
allowPrefix String
s =
    case Bool -> Bool -> () -> () -> String -> Either () a
forall a t e.
(Bounded a, Enum a, Render a, Textual t) =>
Bool -> Bool -> e -> e -> t -> Either e a
parseEnum Bool
allowCI Bool
allowPrefix () () String
s of
      Right a
v -> [(a
v, String
"")]
      Left{}  -> []
{-# INLINEABLE readsEnum #-}

-- | Implement 'ReadS' using a 'Parse' instance
--
-- This implementation expects all of the input to be consumed.
readsWithParse
  :: Parse a
  => ReadS a
readsWithParse :: ReadS a
readsWithParse String
s = case String -> Maybe a
forall a t. (Parse a, Textual t) => t -> Maybe a
parseMaybe String
s of
    Just a
v  -> [(a
v, String
"")]
    Maybe a
Nothing -> []
{-# INLINEABLE readsWithParse #-}

-- $ParseValid

-- | Validate a constant at compile-time using a 'Parse' instance
--
-- This function parses the 'String' at compile-time and fails compilation on
-- error.  When valid, the result is compiled in, so the result type must have
-- a 'THS.Lift' instance.  When this is inconvenient, use one of the
-- alternative functions in this library.
--
-- This function uses a typed expression.  Typed expressions were not
-- supported in @haskell-src-exts <1.22.0@, which caused problems with
-- @hlint@.  If the issue effects you, use @hlint -i "Parse error"@ to ignore
-- parse errors or use one of the alternative functions in this library.
--
-- See the @valid@, @invalid@, and @lift@ example programs in the @examples@
-- directory.
valid
  :: (Parse a, THS.Lift a)
  => String
  -> TH.Q (TH.TExp a)
valid :: String -> Q (TExp a)
valid String
s = case String -> Either String a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse String
s of
    Right a
x -> [|| x ||]
    Left String
err -> String -> Q (TExp a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (TExp a)) -> String -> Q (TExp a)
forall a b. (a -> b) -> a -> b
$ String
"Invalid constant: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

-- | Validate a constant at compile-time using a 'Parse' instance
--
-- This function requires a 'Proxy' of the result type.  Use 'mkValid' to
-- avoid having to pass a 'Proxy' during constant definition.
--
-- This function parses the 'String' at compile-time and fails compilation on
-- error.  When valid, the 'String' is compiled in, to be parsed again at
-- run-time.  Since the result is not compiled in, no 'THS.Lift' instance is
-- required.
--
-- This function uses a typed expression.  Typed expressions were not
-- supported in @haskell-src-exts <1.22.0@, which caused problems with
-- @hlint@.  If the issue effects you, use @hlint -i "Parse error"@ to ignore
-- parse errors or use 'untypedValidOf' instead.
--
-- See the @validof@ example program in the @examples@ directory.
validOf
  :: Parse a
  => Proxy a
  -> String
  -> TH.Q (TH.TExp a)
validOf :: Proxy a -> String -> Q (TExp a)
validOf Proxy a
proxy String
s = case (a -> Proxy a -> a
forall a (proxy :: * -> *). a -> proxy a -> a
`asProxyTypeOf` Proxy a
proxy) (a -> a) -> Either String a -> Either String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse String
s of
    Right{} -> [|| parseUnsafeS s ||]
    Left String
err -> String -> Q (TExp a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (TExp a)) -> String -> Q (TExp a)
forall a b. (a -> b) -> a -> b
$ String
"Invalid constant: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

-- | Make a @valid@ function using 'validOf' for the given type
--
-- Create a @valid@ function in the module for a type in order to avoid having
-- to write a 'Proxy' when defining constants.
--
-- This function uses a typed expression.  Typed expressions were not
-- supported in @haskell-src-exts <1.22.0@, which caused problems with
-- @hlint@.  If the issue effects you, use @hlint -i "Parse error"@ to ignore
-- parse errors or use 'mkUntypedValidOf' instead.
--
-- See the @mkvalid@ example program in the @examples@ directory.
mkValid
  :: String
  -> TH.Name
  -> TH.DecsQ
mkValid :: String -> Name -> DecsQ
mkValid String
funName Name
typeName = do
    let funName' :: Name
funName' = String -> Name
TH.mkName String
funName
        resultType :: Q Type
resultType = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
typeName
    Type
funType <- [t| String -> TH.Q (TH.TExp $resultType) |]
    Exp
body <- [| validOf (Proxy :: Proxy $resultType) |]
    [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Name -> Type -> Dec
TH.SigD Name
funName' Type
funType
      , Name -> [Clause] -> Dec
TH.FunD Name
funName' [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] (Exp -> Body
TH.NormalB Exp
body) []]
      ]

-- | Validate a constant at compile-time using a 'Parse' instance
--
-- This function requires a 'Proxy' of the result type.  Use 'mkUntypedValid'
-- to avoid having to pass a 'Proxy' during constant definition.
--
-- This function parses the 'String' at compile-time and fails compilation on
-- error.  When valid, the 'String' is compiled in, to be parsed again at
-- run-time.  Since the result is not compiled in, no 'THS.Lift' instance is
-- required.
--
-- See the @uvalidof@ example program in the @examples@ directory.
untypedValidOf
  :: Parse a
  => Proxy a
  -> String
  -> TH.ExpQ
untypedValidOf :: Proxy a -> String -> ExpQ
untypedValidOf Proxy a
proxy String
s = case (a -> Proxy a -> a
forall a (proxy :: * -> *). a -> proxy a -> a
`asProxyTypeOf` Proxy a
proxy) (a -> a) -> Either String a -> Either String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String a
forall a t e. (Parse a, Textual t, Textual e) => t -> Either e a
parse String
s of
    Right{} -> [| parseUnsafeS s |]
    Left String
err -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Invalid constant: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

-- | Make a @valid@ function using 'untypedValidOf' for the given type
--
-- Create a @valid@ function in the module for a type in order to avoid having
-- to write a 'Proxy' when defining constants.
--
-- See the @mkuvalid@ example program in the @examples@ directory.
mkUntypedValid
  :: String
  -> TH.Name
  -> TH.DecsQ
mkUntypedValid :: String -> Name -> DecsQ
mkUntypedValid String
funName Name
typeName = do
    let funName' :: Name
funName' = String -> Name
TH.mkName String
funName
        resultType :: Q Type
resultType = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
typeName
    Type
funType <- [t| String -> TH.ExpQ |]
    Exp
body <- [| untypedValidOf (Proxy :: Proxy $resultType) |]
    [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Name -> Type -> Dec
TH.SigD Name
funName' Type
funType
      , Name -> [Clause] -> Dec
TH.FunD Name
funName' [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] (Exp -> Body
TH.NormalB Exp
body) []]
      ]

-- | Make a @valid@ quasi-quoter using 'untypedValidOf' for the given type
--
-- See the @uvalidqq@ example program in the @examples@ directory.
mkUntypedValidQQ
  :: String
  -> TH.Name
  -> TH.DecsQ
mkUntypedValidQQ :: String -> Name -> DecsQ
mkUntypedValidQQ String
funName Name
typeName = do
    let funName' :: Name
funName' = String -> Name
TH.mkName String
funName
        resultType :: Q Type
resultType = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
typeName
    Exp
expE <- [| untypedValidOf (Proxy :: Proxy $resultType) |]
    Exp
expP <- [| error "pattern not supported" |]
    Exp
expT <- [| error "type not supported" |]
    Exp
expD <- [| error "declaration not supported" |]
    let body :: Body
body = Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> [FieldExp] -> Exp
TH.RecConE 'Q.QuasiQuoter
          [ ('Q.quoteExp, Exp
expE)
          , ('Q.quotePat, Exp
expP)
          , ('Q.quoteType, Exp
expT)
          , ('Q.quoteDec, Exp
expD)
          ]
    [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Name -> Type -> Dec
TH.SigD Name
funName' (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT ''Q.QuasiQuoter
      , Name -> [Clause] -> Dec
TH.FunD Name
funName' [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] Body
body []]
      ]