{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
#if __GLASGOW_HASKELL__ >= 900
{-# LANGUAGE ExplicitForAll #-}
#endif
module Data.TTC
(
Textual
, convert
, toS
, toT
, toTL
, toBS
, toBSL
, fromS
, fromT
, fromTL
, fromBS
, fromBSL
, asS
, asT
, asTL
, asBS
, asBSL
, toTLB
, fromTLB
, toBSB
, fromBSB
, toSBS
, fromSBS
, Render(..)
, renderS
, renderT
, renderTL
, renderBS
, renderBSL
, renderTLB
, renderBSB
, renderSBS
, renderWithShow
, Parse(..)
, parseS
, parseT
, parseTL
, parseBS
, parseBSL
, parseMaybe
, parseMaybeS
, parseMaybeT
, parseMaybeTL
, parseMaybeBS
, parseMaybeBSL
, parseUnsafe
, parseUnsafeS
, parseUnsafeT
, parseUnsafeTL
, parseUnsafeBS
, parseUnsafeBSL
, parseEnum
, parseEnum'
, parseWithRead
, parseWithRead'
, maybeParseWithRead
, readsEnum
, readsWithParse
, valid
, validOf
, mkValid
, untypedValidOf
, mkUntypedValid
, mkUntypedValidQQ
) where
import Data.Proxy (Proxy(Proxy), asProxyTypeOf)
import Text.Read (readMaybe)
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
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as Q
import qualified Language.Haskell.TH.Syntax as THS
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
class Textual t where
toS :: t -> String
toT :: t -> T.Text
toTL :: t -> TL.Text
toBS :: t -> BS.ByteString
toBSL :: t -> BSL.ByteString
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 #-}
fromS :: Textual t => String -> t
fromS :: String -> t
fromS = String -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromS #-}
fromT :: Textual t => T.Text -> t
fromT :: Text -> t
fromT = Text -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromT #-}
fromTL :: Textual t => TL.Text -> t
fromTL :: Text -> t
fromTL = Text -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromTL #-}
fromBS :: Textual t => BS.ByteString -> t
fromBS :: ByteString -> t
fromBS = ByteString -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromBS #-}
fromBSL :: Textual t => BSL.ByteString -> t
fromBSL :: ByteString -> t
fromBSL = ByteString -> t
forall t t'. (Textual t, Textual t') => t' -> t
convert
{-# INLINE fromBSL #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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
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
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
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
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
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
class Render a where
render :: Textual t => a -> t
renderS :: Render a => a -> String
renderS :: a -> String
renderS = a -> String
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderS #-}
renderT :: Render a => a -> T.Text
renderT :: a -> Text
renderT = a -> Text
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderT #-}
renderTL :: Render a => a -> TL.Text
renderTL :: a -> Text
renderTL = a -> Text
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderTL #-}
renderBS :: Render a => a -> BS.ByteString
renderBS :: a -> ByteString
renderBS = a -> ByteString
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderBS #-}
renderBSL :: Render a => a -> BSL.ByteString
renderBSL :: a -> ByteString
renderBSL = a -> ByteString
forall a t. (Render a, Textual t) => a -> t
render
{-# INLINE renderBSL #-}
renderTLB :: Render a => a -> TLB.Builder
renderTLB :: a -> Builder
renderTLB = Text -> Builder
TLB.fromLazyText (Text -> Builder) -> (a -> Text) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Render a => a -> Text
renderTL
{-# INLINE renderTLB #-}
renderBSB :: Render a => a -> BSB.Builder
renderBSB :: a -> Builder
renderBSB = ByteString -> Builder
BSB.lazyByteString (ByteString -> Builder) -> (a -> ByteString) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Render a => a -> ByteString
renderBSL
{-# INLINE renderBSB #-}
renderSBS :: Render a => a -> SBS.ShortByteString
renderSBS :: a -> ShortByteString
renderSBS = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString)
-> (a -> ByteString) -> a -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Render a => a -> ByteString
renderBS
{-# INLINE renderSBS #-}
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 #-}
class Parse a where
parse :: (Textual t, Textual e) => t -> Either e a
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' #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 :: (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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 :: (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 #-}
parseUnsafeS :: Parse a => String -> a
parseUnsafeS :: String -> a
parseUnsafeS = String -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeS #-}
parseUnsafeT :: Parse a => T.Text -> a
parseUnsafeT :: Text -> a
parseUnsafeT = Text -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeT #-}
parseUnsafeTL :: Parse a => TL.Text -> a
parseUnsafeTL :: Text -> a
parseUnsafeTL = Text -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeTL #-}
parseUnsafeBS :: Parse a => BS.ByteString -> a
parseUnsafeBS :: ByteString -> a
parseUnsafeBS = ByteString -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeBS #-}
parseUnsafeBSL :: Parse a => BSL.ByteString -> a
parseUnsafeBSL :: ByteString -> a
parseUnsafeBSL = ByteString -> a
forall a t. (Parse a, Textual t) => t -> a
parseUnsafe
{-# INLINE parseUnsafeBSL #-}
parseEnum
:: (Bounded a, Enum a, Render a, Textual t)
=> Bool
-> Bool
-> e
-> e
-> t
-> Either e a
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]
_vs -> 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
(==)
parseEnum'
:: (Bounded a, Enum a, Render a, Textual t, Textual e)
=> String
-> Bool
-> Bool
-> t
-> Either e a
parseEnum' :: String -> Bool -> Bool -> t -> Either e a
parseEnum' String
name Bool
allowCI Bool
allowPrefix =
Bool -> Bool -> e -> e -> t -> Either e 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 -> 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)
(String -> e
forall t. Textual t => String -> t
fromS (String -> e) -> String -> e
forall a b. (a -> b) -> a -> b
$ String
"ambiguous " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
{-# INLINEABLE parseEnum' #-}
parseWithRead
:: (Read a, Textual t)
=> e
-> t
-> Either e a
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 #-}
parseWithRead'
:: (Read a, Textual t, Textual e)
=> String
-> t
-> Either e a
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' #-}
maybeParseWithRead
:: (Read a, Textual t)
=> t
-> Maybe a
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
readsEnum
:: (Bounded a, Enum a, Render a)
=> Bool
-> Bool
-> 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 #-}
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 #-}
#if __GLASGOW_HASKELL__ >= 900
valid
:: (MonadFail m, THS.Quote m, Parse a, THS.Lift a)
=> String
-> THS.Code m a
valid s = case parse s of
Right x -> [|| x ||]
Left err -> THS.Code . fail $ "Invalid constant: " ++ err
#else
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
#endif
#if __GLASGOW_HASKELL__ >= 900
validOf
:: (MonadFail m, THS.Quote m, Parse a)
=> Proxy a
-> String
-> THS.Code m a
validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of
Right{} -> [|| parseUnsafeS s ||]
Left err -> THS.Code . fail $ "Invalid constant: " ++ err
#else
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
#endif
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
#if __GLASGOW_HASKELL__ >= 900
funType <-
[t|
forall m . (MonadFail m, THS.Quote m) =>
String -> THS.Code m $resultType
|]
#else
Type
funType <- [t| String -> TH.Q (TH.TExp $resultType) |]
#endif
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) []]
]
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
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) []]
]
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 []]
]