{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module ValidLiterals
( Validate(..)
, ValidationFailure(..)
, valid
, validInteger
, validRational
, validString
, validList
, Lift(..)
) where
import Control.Exception (Exception(displayException), throwIO)
import Data.Proxy (Proxy(Proxy))
import Data.Typeable (Typeable)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax.Compat (Splice, liftSplice)
data ValidationFailure = ValidationFailure String deriving (Int -> ValidationFailure -> ShowS
[ValidationFailure] -> ShowS
ValidationFailure -> String
(Int -> ValidationFailure -> ShowS)
-> (ValidationFailure -> String)
-> ([ValidationFailure] -> ShowS)
-> Show ValidationFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationFailure] -> ShowS
$cshowList :: [ValidationFailure] -> ShowS
show :: ValidationFailure -> String
$cshow :: ValidationFailure -> String
showsPrec :: Int -> ValidationFailure -> ShowS
$cshowsPrec :: Int -> ValidationFailure -> ShowS
Show, Typeable)
instance Exception ValidationFailure where
displayException :: ValidationFailure -> String
displayException (ValidationFailure String
s) = String
"Validation failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
class Validate a b where
fromLiteralWithError :: a -> Either String b
fromLiteralWithError = Either String b
-> (b -> Either String b) -> Maybe b -> Either String b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String b
forall a b. a -> Either a b
Left String
errMsg) b -> Either String b
forall a b. b -> Either a b
Right (Maybe b -> Either String b)
-> (a -> Maybe b) -> a -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
forall a b. Validate a b => a -> Maybe b
fromLiteral
where
errMsg :: String
errMsg = String
"An error occured during compile-time validation!"
fromLiteral :: a -> Maybe b
fromLiteral = (String -> Maybe b) -> (b -> Maybe b) -> Either String b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> String -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just (Either String b -> Maybe b)
-> (a -> Either String b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String b
forall a b. Validate a b => a -> Either String b
fromLiteralWithError
{-# MINIMAL fromLiteralWithError | fromLiteral #-}
liftResult :: Proxy a -> b -> Splice Q b
default liftResult :: Lift b => Proxy a -> b -> Splice Q b
liftResult Proxy a
_ b
val = [|| val ||]
valid :: forall a b . Validate a b => a -> Splice Q b
valid :: a -> Splice Q b
valid a
input = case a -> Either String b
forall a b. Validate a b => a -> Either String b
fromLiteralWithError a
input of
Right b
result -> Proxy a -> b -> Splice Q b
forall a b. Validate a b => Proxy a -> b -> Splice Q b
liftResult (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) b
result
Left String
err -> Splice Q b -> Splice Q b
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice (Splice Q b -> Splice Q b) -> Splice Q b -> Splice Q b
forall a b. (a -> b) -> a -> b
$ do
String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"Invalid input used for type-safe validated literal!", String
err ]
IO (TExp b) -> Splice Q b
forall a. IO a -> Q a
runIO (IO (TExp b) -> Splice Q b) -> IO (TExp b) -> Splice Q b
forall a b. (a -> b) -> a -> b
$ ValidationFailure -> IO (TExp b)
forall e a. Exception e => e -> IO a
throwIO (String -> ValidationFailure
ValidationFailure String
err)
validInteger :: Validate Integer b => Integer -> Splice Q b
validInteger :: Integer -> Splice Q b
validInteger = Integer -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid
validRational :: Validate Rational b => Rational -> Splice Q b
validRational :: Rational -> Splice Q b
validRational = Rational -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid
validString :: Validate String b => String -> Splice Q b
validString :: String -> Splice Q b
validString = String -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid
validList :: Validate [a] b => [a] -> Splice Q b
validList :: [a] -> Splice Q b
validList = [a] -> Splice Q b
forall a b. Validate a b => a -> Splice Q b
valid